home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / graphics.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  168.4 KB  |  6,117 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. //!! Add bitmap options set (dither, systemcolors, savepalette, ...)
  11.  
  12. //!! Implement TMemoryMappedStream, check TBitmap support
  13.  
  14. unit Graphics;
  15.  
  16. {$P+,S-,W-,R-}
  17. {$C PRELOAD}
  18.  
  19. interface
  20.  
  21. uses Windows, SysUtils, Classes;
  22.  
  23. { Graphics Objects }
  24.  
  25. type
  26.   TColor = $80000000..$7FFFFFFF;
  27.  
  28. const
  29.   clScrollBar = TColor(COLOR_SCROLLBAR or $80000000);
  30.   clBackground = TColor(COLOR_BACKGROUND or $80000000);
  31.   clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000);
  32.   clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000);
  33.   clMenu = TColor(COLOR_MENU or $80000000);
  34.   clWindow = TColor(COLOR_WINDOW or $80000000);
  35.   clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000);
  36.   clMenuText = TColor(COLOR_MENUTEXT or $80000000);
  37.   clWindowText = TColor(COLOR_WINDOWTEXT or $80000000);
  38.   clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000);
  39.   clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000);
  40.   clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000);
  41.   clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000);
  42.   clHighlight = TColor(COLOR_HIGHLIGHT or $80000000);
  43.   clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000);
  44.   clBtnFace = TColor(COLOR_BTNFACE or $80000000);
  45.   clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000);
  46.   clGrayText = TColor(COLOR_GRAYTEXT or $80000000);
  47.   clBtnText = TColor(COLOR_BTNTEXT or $80000000);
  48.   clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000);
  49.   clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000);
  50.   cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000);
  51.   cl3DLight = TColor(COLOR_3DLIGHT or $80000000);
  52.   clInfoText = TColor(COLOR_INFOTEXT or $80000000);
  53.   clInfoBk = TColor(COLOR_INFOBK or $80000000);
  54.  
  55.   clBlack = TColor($000000);
  56.   clMaroon = TColor($000080);
  57.   clGreen = TColor($008000);
  58.   clOlive = TColor($008080);
  59.   clNavy = TColor($800000);
  60.   clPurple = TColor($800080);
  61.   clTeal = TColor($808000);
  62.   clGray = TColor($808080);
  63.   clSilver = TColor($C0C0C0);
  64.   clRed = TColor($0000FF);
  65.   clLime = TColor($00FF00);
  66.   clYellow = TColor($00FFFF);
  67.   clBlue = TColor($FF0000);
  68.   clFuchsia = TColor($FF00FF);
  69.   clAqua = TColor($FFFF00);
  70.   clLtGray = TColor($C0C0C0);
  71.   clDkGray = TColor($808080);
  72.   clWhite = TColor($FFFFFF);
  73.   clNone = TColor($1FFFFFFF);
  74.   clDefault = TColor($20000000);
  75.  
  76. const
  77.   cmBlackness = BLACKNESS;
  78.   cmDstInvert = DSTINVERT;
  79.   cmMergeCopy = MERGECOPY;
  80.   cmMergePaint = MERGEPAINT;
  81.   cmNotSrcCopy = NOTSRCCOPY;
  82.   cmNotSrcErase = NOTSRCERASE;
  83.   cmPatCopy = PATCOPY;
  84.   cmPatInvert = PATINVERT;
  85.   cmPatPaint = PATPAINT;
  86.   cmSrcAnd = SRCAND;
  87.   cmSrcCopy = SRCCOPY;
  88.   cmSrcErase = SRCERASE;
  89.   cmSrcInvert = SRCINVERT;
  90.   cmSrcPaint = SRCPAINT;
  91.   cmWhiteness = WHITENESS;
  92.  
  93. type
  94.   HMETAFILE = THandle;
  95.   HENHMETAFILE = THandle;
  96.  
  97.   EInvalidGraphic = class(Exception);
  98.   EInvalidGraphicOperation = class(Exception);
  99.  
  100.   TGraphic = class;
  101.   TBitmap = class;
  102.   TIcon = class;
  103.   TMetafile = class;
  104.  
  105.   TResData = record
  106.     Handle: THandle;
  107.   end;
  108.  
  109.   TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
  110.   TFontStyles = set of TFontStyle;
  111.   TFontPitch = (fpDefault, fpVariable, fpFixed);
  112.   TFontName = type string;
  113.   TFontCharset = 0..255;
  114.  
  115.   TFontData = record
  116.     Handle: HFont;
  117.     Height: Integer;
  118.     Pitch: TFontPitch;
  119.     Style: TFontStyles;
  120.     Charset: TFontCharset;
  121.     Name: string[LF_FACESIZE - 1];
  122.   end;
  123.  
  124.   TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
  125.     psInsideFrame);
  126.   TPenMode = (pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy,
  127.     pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge,
  128.     pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor);
  129.  
  130.   TPenData = record
  131.     Handle: HPen;
  132.     Color: TColor;
  133.     Width: Integer;
  134.     Style: TPenStyle;
  135.   end;
  136.  
  137.   TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
  138.     bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
  139.  
  140.   TBrushData = record
  141.     Handle: HBrush;
  142.     Color: TColor;
  143.     Bitmap: TBitmap;
  144.     Style: TBrushStyle;
  145.   end;
  146.  
  147.   PResource = ^TResource;
  148.   TResource = record
  149.     Next: PResource;
  150.     RefCount: Integer;
  151.     Handle: THandle;
  152.     HashCode: Word;
  153.     case Integer of
  154.       0: (Data: TResData);
  155.       1: (Font: TFontData);
  156.       2: (Pen: TPenData);
  157.       3: (Brush: TBrushData);
  158.   end;
  159.  
  160.   TGraphicsObject = class(TPersistent)
  161.   private
  162.     FOnChange: TNotifyEvent;
  163.     FResource: PResource;
  164.     FOwnerLock: PRTLCriticalSection;
  165.   protected
  166.     procedure Changed; dynamic;
  167.     procedure Lock;
  168.     procedure Unlock;
  169.   public
  170.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  171.     property OwnerCriticalSection: PRTLCriticalSection read FOwnerLock write FOwnerLock;
  172.   end;
  173.  
  174.   IChangeNotifier = interface
  175.     ['{1FB62321-44A7-11D0-9E93-0020AF3D82DA}']
  176.     procedure Changed;
  177.   end;
  178.  
  179.   TFont = class(TGraphicsObject)
  180.   private
  181.     FColor: TColor;
  182.     FPixelsPerInch: Integer;
  183.     FNotify: IChangeNotifier;
  184.     procedure GetData(var FontData: TFontData);
  185.     procedure SetData(const FontData: TFontData);
  186.   protected
  187.     procedure Changed; override;
  188.     function GetHandle: HFont;
  189.     function GetHeight: Integer;
  190.     function GetName: TFontName;
  191.     function GetPitch: TFontPitch;
  192.     function GetSize: Integer;
  193.     function GetStyle: TFontStyles;
  194.     function GetCharset: TFontCharset;
  195.     procedure SetColor(Value: TColor);
  196.     procedure SetHandle(Value: HFont);
  197.     procedure SetHeight(Value: Integer);
  198.     procedure SetName(const Value: TFontName);
  199.     procedure SetPitch(Value: TFontPitch);
  200.     procedure SetSize(Value: Integer);
  201.     procedure SetStyle(Value: TFontStyles);
  202.     procedure SetCharset(Value: TFontCharset);
  203.   public
  204.     constructor Create;
  205.     destructor Destroy; override;
  206.     procedure Assign(Source: TPersistent); override;
  207.     property FontAdapter: IChangeNotifier read FNotify write FNotify;
  208.     property Handle: HFont read GetHandle write SetHandle;
  209.     property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
  210.   published
  211.     property Charset: TFontCharset read GetCharset write SetCharset nodefault;
  212.     property Color: TColor read FColor write SetColor;
  213.     property Height: Integer read GetHeight write SetHeight;
  214.     property Name: TFontName read GetName write SetName;
  215.     property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
  216.     property Size: Integer read GetSize write SetSize stored False;
  217.     property Style: TFontStyles read GetStyle write SetStyle;
  218.   end;
  219.  
  220.   TPen = class(TGraphicsObject)
  221.   private
  222.     FMode: TPenMode;
  223.     procedure GetData(var PenData: TPenData);
  224.     procedure SetData(const PenData: TPenData);
  225.   protected
  226.     function GetColor: TColor;
  227.     procedure SetColor(Value: TColor);
  228.     function GetHandle: HPen;
  229.     procedure SetHandle(Value: HPen);
  230.     procedure SetMode(Value: TPenMode);
  231.     function GetStyle: TPenStyle;
  232.     procedure SetStyle(Value: TPenStyle);
  233.     function GetWidth: Integer;
  234.     procedure SetWidth(Value: Integer);
  235.   public
  236.     constructor Create;
  237.     destructor Destroy; override;
  238.     procedure Assign(Source: TPersistent); override;
  239.     property Handle: HPen read GetHandle write SetHandle;
  240.   published
  241.     property Color: TColor read GetColor write SetColor default clBlack;
  242.     property Mode: TPenMode read FMode write SetMode default pmCopy;
  243.     property Style: TPenStyle read GetStyle write SetStyle default psSolid;
  244.     property Width: Integer read GetWidth write SetWidth default 1;
  245.   end;
  246.  
  247.   TBrush = class(TGraphicsObject)
  248.   private
  249.     procedure GetData(var BrushData: TBrushData);
  250.     procedure SetData(const BrushData: TBrushData);
  251.   protected
  252.     function GetBitmap: TBitmap;
  253.     procedure SetBitmap(Value: TBitmap);
  254.     function GetColor: TColor;
  255.     procedure SetColor(Value: TColor);
  256.     function GetHandle: HBrush;
  257.     procedure SetHandle(Value: HBrush);
  258.     function GetStyle: TBrushStyle;
  259.     procedure SetStyle(Value: TBrushStyle);
  260.   public
  261.     constructor Create;
  262.     destructor Destroy; override;
  263.     procedure Assign(Source: TPersistent); override;
  264.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  265.     property Handle: HBrush read GetHandle write SetHandle;
  266.   published
  267.     property Color: TColor read GetColor write SetColor default clWhite;
  268.     property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
  269.   end;
  270.  
  271.   TFillStyle = (fsSurface, fsBorder);
  272.   TFillMode = (fmAlternate, fmWinding);
  273.  
  274.   TCopyMode = Longint;
  275.  
  276.   TCanvasStates = (csHandleValid, csFontValid, csPenValid, csBrushValid);
  277.   TCanvasState = set of TCanvasStates;
  278.  
  279.   TCanvas = class(TPersistent)
  280.   private
  281.     FHandle: HDC;
  282.     State: TCanvasState;
  283.     FFont: TFont;
  284.     FPen: TPen;
  285.     FBrush: TBrush;
  286.     FPenPos: TPoint;
  287.     FCopyMode: TCopyMode;
  288.     FOnChange: TNotifyEvent;
  289.     FOnChanging: TNotifyEvent;
  290.     FLock: TRTLCriticalSection;
  291.     FLockCount: Integer;
  292.     procedure CreateBrush;
  293.     procedure CreateFont;
  294.     procedure CreatePen;
  295.     procedure BrushChanged(ABrush: TObject);
  296.     procedure DeselectHandles;
  297.     function GetClipRect: TRect;
  298.     function GetHandle: HDC;
  299.     function GetPenPos: TPoint;
  300.     function GetPixel(X, Y: Integer): TColor;
  301.     procedure FontChanged(AFont: TObject);
  302.     procedure PenChanged(APen: TObject);
  303.     procedure SetBrush(Value: TBrush);
  304.     procedure SetFont(Value: TFont);
  305.     procedure SetHandle(Value: HDC);
  306.     procedure SetPen(Value: TPen);
  307.     procedure SetPenPos(Value: TPoint);
  308.     procedure SetPixel(X, Y: Integer; Value: TColor);
  309.   protected
  310.     procedure Changed; virtual;
  311.     procedure Changing; virtual;
  312.     procedure CreateHandle; virtual;
  313.     procedure RequiredState(ReqState: TCanvasState);
  314.   public
  315.     constructor Create;
  316.     destructor Destroy; override;
  317.     procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  318.     procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  319.       const Source: TRect; Color: TColor);
  320.     procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  321.     procedure CopyRect(const Dest: TRect; Canvas: TCanvas;
  322.       const Source: TRect);
  323.     procedure Draw(X, Y: Integer; Graphic: TGraphic);
  324.     procedure DrawFocusRect(const Rect: TRect);
  325.     procedure Ellipse(X1, Y1, X2, Y2: Integer);
  326.     procedure FillRect(const Rect: TRect);
  327.     procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
  328.     procedure FrameRect(const Rect: TRect);
  329.     procedure LineTo(X, Y: Integer);
  330.     procedure Lock;
  331.     procedure MoveTo(X, Y: Integer);
  332.     procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  333.     procedure Polygon(const Points: array of TPoint);
  334.     procedure Polyline(const Points: array of TPoint);
  335.     procedure Rectangle(X1, Y1, X2, Y2: Integer);
  336.     procedure Refresh;
  337.     procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  338.     procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
  339.     function TextExtent(const Text: string): TSize;
  340.     function TextHeight(const Text: string): Integer;
  341.     procedure TextOut(X, Y: Integer; const Text: string);
  342.     procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  343.     function TextWidth(const Text: string): Integer;
  344.     procedure Unlock;
  345.     property ClipRect: TRect read GetClipRect;
  346.     property Handle: HDC read GetHandle write SetHandle;
  347.     property LockCount: Integer read FLockCount;
  348.     property PenPos: TPoint read GetPenPos write SetPenPos;
  349.     property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
  350.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  351.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  352.   published
  353.     property Brush: TBrush read FBrush write SetBrush;
  354.     property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
  355.     property Font: TFont read FFont write SetFont;
  356.     property Pen: TPen read FPen write SetPen;
  357.   end;
  358.  
  359.   { TProgressEvent is a generic progress notification event which may be
  360.         used by TGraphic classes with computationally intensive (slow)
  361.         operations, such as loading, storing, or transforming image data.
  362.     Event params:
  363.       Stage - Indicates whether this call to the OnProgress event is to
  364.         prepare for, process, or clean up after a graphic operation.  If
  365.         OnProgress is called at all, the first call for a graphic operation
  366.         will be with Stage = psStarting, to allow the OnProgress event handler
  367.         to allocate whatever resources it needs to process subsequent progress
  368.         notifications.  After Stage = psStarting, you are guaranteed that
  369.         OnProgress will be called again with Stage = psEnding to allow you
  370.         to free those resources, even if the graphic operation is aborted by
  371.         an exception.  Zero or more calls to OnProgress with Stage = psRunning
  372.         may occur between the psStarting and psEnding calls.
  373.       PercentDone - The ratio of work done to work remaining, on a scale of
  374.         0 to 100.  Values may repeat or even regress (get smaller) in
  375.         successive calls.  PercentDone is usually only a guess, and the
  376.         guess may be dramatically altered as new information is discovered
  377.         in decoding the image.
  378.       RedrawNow - Indicates whether the graphic can be/should be redrawn
  379.         immediately.  Useful for showing successive approximations of
  380.         an image as data is available instead of waiting for all the data
  381.         to arrive before drawing anything.  Since there is no message loop
  382.         activity during graphic operations, you should call Update to force
  383.         a control to be redrawn immediately in the OnProgress event handler.
  384.         Redrawing a graphic when RedrawNow = False could corrupt the image
  385.         and/or cause exceptions.
  386.       Rect - Area of image that has changed and needs to be redrawn.
  387.       Msg - Optional text describing in one or two words what the graphic
  388.         class is currently working on.  Ex:  "Loading" "Storing"
  389.         "Reducing colors".  The Msg string can also be empty.
  390.         Msg strings should be resourced for translation,  should not
  391.         contain trailing periods, and should be used only for
  392.         display purposes.  (do not: if Msg = 'Loading' then...)
  393.   }
  394.  
  395.   TProgressStage = (psStarting, psRunning, psEnding);
  396.   TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
  397.     PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;
  398.  
  399.   { The TGraphic class is a abstract base class for dealing with graphic images
  400.     such as metafile, bitmaps, icons, and other image formats.
  401.       LoadFromFile - Read the graphic from the file system.  The old contents of
  402.         the graphic are lost.  If the file is not of the right format, an
  403.         exception will be generated.
  404.       SaveToFile - Writes the graphic to disk in the file provided.
  405.       LoadFromStream - Like LoadFromFile except source is a stream (e.g.
  406.         TBlobStream).
  407.       SaveToStream - stream analogue of SaveToFile.
  408.       LoadFromClipboardFormat - Replaces the current image with the data
  409.         provided.  If the TGraphic does not support that format it will generate
  410.         an exception.
  411.       SaveToClipboardFormats - Converts the image to a clipboard format.  If the
  412.         image does not support being translated into a clipboard format it
  413.         will generate an exception.
  414.       Height - The native, unstretched, height of the graphic.
  415.       Palette - Color palette of image.  Zero if graphic doesn't need/use palettes.
  416.       Transparent - Image does not completely cover its rectangular area
  417.       Width - The native, unstretched, width of the graphic.
  418.       OnChange - Called whenever the graphic changes
  419.       PaletteModified - Indicates in OnChange whether color palette has changed.
  420.         Stays true until whoever's responsible for realizing this new palette
  421.         (ex: TImage) sets it to False.
  422.       OnProgress - Generic progress indicator event. Propagates out to TPicture
  423.         and TImage OnProgress events.}
  424.  
  425.   TGraphic = class(TPersistent)
  426.   private
  427.     FOnChange: TNotifyEvent;
  428.     FOnProgress: TProgressEvent;
  429.     FModified: Boolean;
  430.     FTransparent: Boolean;
  431.     FPaletteModified: Boolean;
  432.     procedure SetModified(Value: Boolean);
  433.   protected
  434.     constructor Create; virtual;
  435.     procedure Changed(Sender: TObject); virtual;
  436.     procedure DefineProperties(Filer: TFiler); override;
  437.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
  438.     function Equals(Graphic: TGraphic): Boolean; virtual;
  439.     function GetEmpty: Boolean; virtual; abstract;
  440.     function GetHeight: Integer; virtual; abstract;
  441.     function GetPalette: HPALETTE; virtual;
  442.     function GetTransparent: Boolean; virtual;
  443.     function GetWidth: Integer; virtual; abstract;
  444.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  445.       PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  446.     procedure ReadData(Stream: TStream); virtual;
  447.     procedure SetHeight(Value: Integer); virtual; abstract;
  448.     procedure SetPalette(Value: HPALETTE); virtual;
  449.     procedure SetTransparent(Value: Boolean); virtual;
  450.     procedure SetWidth(Value: Integer); virtual; abstract;
  451.     procedure WriteData(Stream: TStream); virtual;
  452.   public
  453.     procedure LoadFromFile(const Filename: string); virtual;
  454.     procedure SaveToFile(const Filename: string); virtual;
  455.     procedure LoadFromStream(Stream: TStream); virtual; abstract;
  456.     procedure SaveToStream(Stream: TStream); virtual; abstract;
  457.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  458.       APalette: HPALETTE); virtual; abstract;
  459.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  460.       var APalette: HPALETTE); virtual; abstract;
  461.     property Empty: Boolean read GetEmpty;
  462.     property Height: Integer read GetHeight write SetHeight;
  463.     property Modified: Boolean read FModified write SetModified;
  464.     property Palette: HPALETTE read GetPalette write SetPalette;
  465.     property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
  466.     property Transparent: Boolean read GetTransparent write SetTransparent;
  467.     property Width: Integer read GetWidth write SetWidth;
  468.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  469.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  470.   end;
  471.  
  472.   TGraphicClass = class of TGraphic;
  473.  
  474.   { TPicture }
  475.   { TPicture is a TGraphic container.  It is used in place of a TGraphic if the
  476.     graphic can be of any TGraphic class.  LoadFromFile and SaveToFile are
  477.     polymorphic. For example, if the TPicture is holding an Icon, you can
  478.     LoadFromFile a bitmap file, where if the class was TIcon you could only read
  479.     .ICO files.
  480.       LoadFromFile - Reads a picture from disk.  The TGraphic class created
  481.         determined by the file extension of the file.  If the file extension is
  482.         not recognized an exception is generated.
  483.       SaveToFile - Writes the picture to disk.
  484.       LoadFromClipboardFormat - Reads the picture from the handle provided in
  485.         the given clipboard format.  If the format is not supported, an
  486.         exception is generated.
  487.       SaveToClipboardFormats - Allocates a global handle and writes the picture
  488.         in its native clipboard format (CF_BITMAP for bitmaps, CF_METAFILE
  489.         for metafiles, etc.).  Formats will contain the formats written.
  490.         Returns the number of clipboard items written to the array pointed to
  491.         by Formats and Datas or would be written if either Formats or Datas are
  492.         nil.
  493.       SupportsClipboardFormat - Returns true if the given clipboard format
  494.         is supported by LoadFromClipboardFormat.
  495.       Assign - Copys the contents of the given TPicture.  Used most often in
  496.         the implementation of TPicture properties.
  497.       RegisterFileFormat - Register a new TGraphic class for use in
  498.         LoadFromFile.
  499.       RegisterClipboardFormat - Registers a new TGraphic class for use in
  500.         LoadFromClipboardFormat.
  501.       UnRegisterGraphicClass - Removes all references to the specified TGraphic
  502.         class and all its descendents from the file format and clipboard format
  503.         internal lists.
  504.       Height - The native, unstretched, height of the picture.
  505.       Width - The native, unstretched, width of the picture.
  506.       Graphic - The TGraphic object contained by the TPicture
  507.       Bitmap - Returns a bitmap.  If the contents is not already a bitmap, the
  508.         contents are thrown away and a blank bitmap is returned.
  509.       Icon - Returns an icon.  If the contents is not already an icon, the
  510.         contents are thrown away and a blank icon is returned.
  511.       Metafile - Returns a metafile.  If the contents is not already a metafile,
  512.         the contents are thrown away and a blank metafile is returned. }
  513.   TPicture = class(TPersistent)
  514.   private
  515.     FGraphic: TGraphic;
  516.     FOnChange: TNotifyEvent;
  517.     FNotify: IChangeNotifier;
  518.     FOnProgress: TProgressEvent;
  519.     procedure ForceType(GraphicType: TGraphicClass);
  520.     function GetBitmap: TBitmap;
  521.     function GetHeight: Integer;
  522.     function GetIcon: TIcon;
  523.     function GetMetafile: TMetafile;
  524.     function GetWidth: Integer;
  525.     procedure ReadData(Stream: TStream);
  526.     procedure SetBitmap(Value: TBitmap);
  527.     procedure SetGraphic(Value: TGraphic);
  528.     procedure SetIcon(Value: TIcon);
  529.     procedure SetMetafile(Value: TMetafile);
  530.     procedure WriteData(Stream: TStream);
  531.   protected
  532.     procedure AssignTo(Dest: TPersistent); override;
  533.     procedure Changed(Sender: TObject); dynamic;
  534.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  535.       PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  536.     procedure DefineProperties(Filer: TFiler); override;
  537.   public
  538.     constructor Create;
  539.     destructor Destroy; override;
  540.     procedure LoadFromFile(const Filename: string);
  541.     procedure SaveToFile(const Filename: string);
  542.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  543.       APalette: HPALETTE);
  544.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  545.       var APalette: HPALETTE);
  546.     class function SupportsClipboardFormat(AFormat: Word): Boolean;
  547.     procedure Assign(Source: TPersistent); override;
  548.     class procedure RegisterFileFormat(const AExtension, ADescription: string;
  549.       AGraphicClass: TGraphicClass);
  550.     class procedure RegisterFileFormatRes(const AExtension: String;
  551.       ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  552.     class procedure RegisterClipboardFormat(AFormat: Word;
  553.       AGraphicClass: TGraphicClass);
  554.     class procedure UnregisterGraphicClass(AClass: TGraphicClass);
  555.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  556.     property Graphic: TGraphic read FGraphic write SetGraphic;
  557.     property PictureAdapter: IChangeNotifier read FNotify write FNotify;
  558.     property Height: Integer read GetHeight;
  559.     property Icon: TIcon read GetIcon write SetIcon;
  560.     property Metafile: TMetafile read GetMetafile write SetMetafile;
  561.     property Width: Integer read GetWidth;
  562.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  563.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  564.   end;
  565.  
  566.   { TMetafile }
  567.   { TMetafile is an encapsulation of the Win32 Enhanced metafile.
  568.       Handle - The metafile handle.
  569.       Enhanced - determines how the metafile will be stored on disk.
  570.         Enhanced = True (default) stores as EMF (Win32 Enhanced Metafile),
  571.         Enhanced = False stores as WMF (Windows 3.1 Metafile, with Aldus header).
  572.         The in-memory format is always EMF.  WMF has very limited capabilities;
  573.         storing as WMF will lose information that would be retained by EMF.
  574.         This property is set to match the metafile type when loaded from a
  575.         stream or file.  This maintains form file compatibility with 16 bit
  576.         Delphi (If loaded as WMF, then save as WMF).
  577.       Inch - The units per inch assumed by a WMF metafile.  Used to alter
  578.         scale when writing as WMF, but otherwise this property is obsolete.
  579.         Enhanced metafiles maintain complete scale information internally.
  580.       MMWidth,
  581.       MMHeight: Width and Height in 0.01 millimeter units, the native
  582.         scale used by enhanced metafiles.  The Width and Height properties
  583.         are always in screen device pixel units; you can avoid loss of
  584.         precision in converting between device pixels and mm by setting
  585.         or reading the dimentions in mm with these two properties.
  586.       CreatedBy - Optional name of the author or application used to create
  587.         the metafile.
  588.       Description - Optional text description of the metafile.
  589.       You can set the CreatedBy and Description of a new metafile by calling
  590.       TMetafileCanvas.CreateWithComment.
  591.  
  592.     TMetafileCanvas
  593.       To create a metafile image from scratch, you must draw the image in
  594.       a metafile canvas.  When the canvas is destroyed, it transfers the
  595.       image into the metafile object provided to the canvas constructor.
  596.       After the image is drawn on the canvas and the canvas is destroyed,
  597.       the image is 'playable' in the metafile object.  Like this:
  598.  
  599.       MyMetafile := TMetafile.Create;
  600.       MyMetafile.Width := 200;
  601.       MyMetafile.Height := 200;
  602.       with TMetafileCanvas.Create(MyMetafile, 0) do
  603.       try
  604.         Brush.Color := clRed;
  605.         Ellipse(0,0,100,100);
  606.         ...
  607.       finally
  608.         Free;
  609.       end;
  610.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle  *)
  611.  
  612.       To add to an existing metafile image, create a metafile canvas
  613.       and play the source metafile into the metafile canvas.  Like this:
  614.  
  615.       (* continued from previous example, so MyMetafile contains an image *)
  616.       with TMetafileCanvas.Create(MyMetafile, 0) do
  617.       try
  618.         Draw(0,0,MyMetafile);
  619.         Brush.Color := clBlue;
  620.         Ellipse(100,100,200,200);
  621.         ...
  622.       finally
  623.         Free;
  624.       end;
  625.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle and 1 blue circle *)
  626.   }
  627.  
  628.   TMetafileCanvas = class(TCanvas)
  629.   private
  630.     FMetafile: TMetafile;
  631.   public
  632.     constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  633.     constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC;
  634.       const CreatedBy, Description: String);
  635.     destructor Destroy; override;
  636.   end;
  637.  
  638.   TSharedImage = class
  639.   private
  640.     FRefCount: Integer;
  641.   protected
  642.     procedure Reference;
  643.     procedure Release;
  644.     procedure FreeHandle; virtual; abstract;
  645.     property RefCount: Integer read FRefCount;
  646.   end;
  647.  
  648.   TMetafileImage = class(TSharedImage)
  649.   private
  650.     FHandle: HENHMETAFILE;
  651.     FWidth: Integer;      // FWidth and FHeight are in 0.01 mm logical pixels
  652.     FHeight: Integer;     // These are converted to device pixels in TMetafile
  653.     FPalette: HPALETTE;
  654.     FInch: Word;          // Used only when writing WMF files.
  655.     FTempWidth: Integer;  // FTempWidth and FTempHeight are in device pixels
  656.     FTempHeight: Integer; // Used only when width/height are set when FHandle = 0
  657.   protected
  658.     procedure FreeHandle; override;
  659.   public
  660.     destructor Destroy; override;
  661.   end;
  662.  
  663.   TMetafile = class(TGraphic)
  664.   private
  665.     FImage: TMetafileImage;
  666.     FEnhanced: Boolean;
  667.     function GetAuthor: String;
  668.     function GetDesc: String;
  669.     function GetHandle: HENHMETAFILE;
  670.     function GetInch: Word;
  671.     function GetMMHeight: Integer;
  672.     function GetMMWidth: Integer;
  673.     procedure NewImage;
  674.     procedure SetHandle(Value: HENHMETAFILE);
  675.     procedure SetInch(Value: Word);
  676.     procedure SetMMHeight(Value: Integer);
  677.     procedure SetMMWidth(Value: Integer);
  678.     procedure UniqueImage;
  679.   protected
  680.     function GetEmpty: Boolean; override;
  681.     function GetHeight: Integer; override;
  682.     function GetPalette: HPALETTE; override;
  683.     function GetWidth: Integer; override;
  684.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  685.     procedure ReadData(Stream: TStream); override;
  686.     procedure ReadEMFStream(Stream: TStream);
  687.     procedure ReadWMFStream(Stream: TStream; Length: Longint);
  688.     procedure SetHeight(Value: Integer); override;
  689.     procedure SetWidth(Value: Integer); override;
  690.     function  TestEMF(Stream: TStream): Boolean;
  691.     procedure WriteData(Stream: TStream); override;
  692.     procedure WriteEMFStream(Stream: TStream);
  693.     procedure WriteWMFStream(Stream: TStream);
  694.   public
  695.     constructor Create; override;
  696.     destructor Destroy; override;
  697.     procedure Clear;
  698.     procedure LoadFromStream(Stream: TStream); override;
  699.     procedure SaveToFile(const Filename: String); override;
  700.     procedure SaveToStream(Stream: TStream); override;
  701.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  702.       APalette: HPALETTE); override;
  703.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  704.       var APalette: HPALETTE); override;
  705.     procedure Assign(Source: TPersistent); override;
  706.     function ReleaseHandle: HENHMETAFILE;
  707.     property CreatedBy: String read GetAuthor;
  708.     property Description: String read GetDesc;
  709.     property Enhanced: Boolean read FEnhanced write FEnhanced default True;
  710.     property Handle: HENHMETAFILE read GetHandle write SetHandle;
  711.     property MMWidth: Integer read GetMMWidth write SetMMWidth;
  712.     property MMHeight: Integer read GetMMHeight write SetMMHeight;
  713.     property Inch: Word read GetInch write SetInch;
  714.   end;
  715.  
  716.   { TBitmap }
  717.   { TBitmap is an encapsulation of a Windows HBITMAP and HPALETTE.  It manages
  718.     the palette realizing automatically as well as having a Canvas to allow
  719.     modifications to the image.  Creating copies of a TBitmap is very fast
  720.     since the handle is copied not the image.  If the image is modified, and
  721.     the handle is shared by more than one TBitmap object, the image is copied
  722.     before the modification is performed (i.e. copy on write).
  723.       Canvas - Allows drawing on the bitmap.
  724.       Handle - The HBITMAP encapsulated by the TBitmap.  Grabbing the handle
  725.         directly should be avoided since it causes the HBITMAP to be copied if
  726.         more than one TBitmap share the handle.
  727.       Palette - The HPALETTE realized by the TBitmap.  Grabbing this handle
  728.         directly should be avoided since it causes the HPALETTE to be copied if
  729.         more than one TBitmap share the handle.
  730.       Monochrome - True if the bitmap is a monochrome bitmap }
  731.  
  732.   TBitmapImage = class(TSharedImage)
  733.   private
  734.     FHandle: HBITMAP;     // DDB or DIB handle, used for drawing
  735.     FPalette: HPALETTE;
  736.     FDIBHandle: HBITMAP;  // DIB handle corresponding to TDIBSection
  737.     FDIB: TDIBSection;
  738.     FOS2Format: Boolean;  // Write BMP file header, color table in OS/2 format
  739.     FHalftone: Boolean;   // FPalette is halftone; don't write to file
  740.   protected
  741.     destructor Destroy; override;
  742.     procedure FreeHandle; override;
  743.   end;
  744.  
  745.   TBitmapHandleType = (bmDIB, bmDDB);
  746.   TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
  747.  
  748.   TBitmap = class(TGraphic)
  749.   private
  750.     FImage: TBitmapImage;
  751.     FCanvas: TCanvas;
  752.     FIgnorePalette: Boolean;
  753.     procedure Changing(Sender: TObject);
  754.     procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
  755.     procedure DIBNeeded;
  756.     procedure FreeContext;
  757.     function GetCanvas: TCanvas;
  758.     function GetHandle: HBITMAP; virtual;
  759.     function GetHandleType: TBitmapHandleType;
  760.     function GetMonochrome: Boolean;
  761.     function GetPixelFormat: TPixelFormat;
  762.     function GetScanline(Row: Integer): Pointer;
  763.     function GetTransparentColor: TColor;
  764.     procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  765.       const NewDIB: TDIBSection; OS2Format: Boolean);
  766.     procedure ReadStream(Stream: TStream; Size: Longint);
  767.     procedure ReadDIB(Stream: TStream; ImageSize: Longint);
  768.     procedure SetHandle(Value: HBITMAP);
  769.     procedure SetHandleType(Value: TBitmapHandleType); virtual;
  770.     procedure SetMonochrome(Value: Boolean);
  771.     procedure SetPixelFormat(Value: TPixelFormat);
  772.     procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  773.   protected
  774.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  775.     function GetEmpty: Boolean; override;
  776.     function GetHeight: Integer; override;
  777.     function GetPalette: HPALETTE; override;
  778.     function GetWidth: Integer; override;
  779.     procedure HandleNeeded;
  780.     procedure PaletteNeeded;
  781.     procedure ReadData(Stream: TStream); override;
  782.     procedure SetHeight(Value: Integer); override;
  783.     procedure SetPalette(Value: HPALETTE); override;
  784.     procedure SetWidth(Value: Integer); override;
  785.     procedure WriteData(Stream: TStream); override;
  786.   public
  787.     constructor Create; override;
  788.     destructor Destroy; override;
  789.     procedure Assign(Source: TPersistent); override;
  790.     procedure Dormant;
  791.     procedure FreeImage;
  792.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  793.       APalette: HPALETTE); override;
  794.     procedure LoadFromStream(Stream: TStream); override;
  795.     procedure LoadFromResourceName(Instance: THandle; const ResName: String);
  796.     procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
  797.     function ReleaseHandle: HBITMAP;
  798.     function ReleasePalette: HPALETTE;
  799.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  800.       var APalette: HPALETTE); override;
  801.     procedure SaveToStream(Stream: TStream); override;
  802.     property ScanLine[Row: Integer]: Pointer read GetScanLine;
  803.     property Canvas: TCanvas read GetCanvas;
  804.     property Handle: HBITMAP read GetHandle write SetHandle;
  805.     property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
  806.     property IgnorePalette: Boolean read FIgnorePalette write FIgnorePalette;
  807.     property Monochrome: Boolean read GetMonochrome write SetMonochrome;
  808.     property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
  809.     property TransparentColor: TColor read GetTransparentColor;
  810.   end;
  811.  
  812.   { TIcon }
  813.   { TIcon encapsulates window HICON handle. Drawing of an icon does not stretch
  814.     so calling stretch draw is not meaningful.
  815.       Handle - The HICON used by the TIcon. }
  816.  
  817.   TIconImage = class(TSharedImage)
  818.   private
  819.     FHandle: HICON;
  820.     FMemoryImage: TCustomMemoryStream;
  821.   protected
  822.     destructor Destroy; override;
  823.     procedure FreeHandle; override;
  824.   end;
  825.  
  826.   TIcon = class(TGraphic)
  827.   private
  828.     FImage: TIconImage;
  829.     function GetHandle: HICON;
  830.     procedure HandleNeeded;
  831.     procedure ImageNeeded;
  832.     procedure NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  833.     procedure SetHandle(Value: HICON);
  834.   protected
  835.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  836.     function GetEmpty: Boolean; override;
  837.     function GetHeight: Integer; override;
  838.     function GetWidth: Integer; override;
  839.     procedure SetHeight(Value: Integer); override;
  840.     procedure SetWidth(Value: Integer); override;
  841.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  842.       APalette: HPALETTE); override;
  843.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  844.       var APalette: HPALETTE); override;
  845.   public
  846.     constructor Create; override;
  847.     destructor Destroy; override;
  848.     procedure Assign(Source: TPersistent); override;
  849.     procedure LoadFromStream(Stream: TStream); override;
  850.     function ReleaseHandle: HICON;
  851.     procedure SaveToStream(Stream: TStream); override;
  852.     property Handle: HICON read GetHandle write SetHandle;
  853.   end;
  854.  
  855. var    // New TFont instances are intialized with the values in this structure:
  856.   DefFontData: TFontData = (
  857.     Handle: 0;
  858.     Height: 0;
  859.     Pitch: fpDefault;
  860.     Style: [];
  861.     Charset : DEFAULT_CHARSET;
  862.     Name: 'MS Sans Serif');
  863.  
  864.  // 16 color palette that maps to the system palette
  865. var
  866.   SystemPalette16: HPalette;
  867.  
  868. function GraphicFilter(GraphicClass: TGraphicClass): string;
  869. function GraphicExtension(GraphicClass: TGraphicClass): string;
  870. function GraphicFileMask(GraphicClass: TGraphicClass): string;
  871.  
  872. function ColorToRGB(Color: TColor): Longint;
  873. function ColorToString(Color: TColor): string;
  874. function StringToColor(const S: string): TColor;
  875. procedure GetColorValues(Proc: TGetStrProc);
  876. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  877. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  878. procedure GetCharsetValues(Proc: TGetStrProc);
  879. function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
  880. function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
  881.  
  882. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  883.   var ImageSize: DWORD);
  884. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  885.  
  886. function CopyPalette(Palette: HPALETTE): HPALETTE;
  887.  
  888. procedure PaletteChanged;
  889. procedure FreeMemoryContexts;
  890.  
  891. function CreateMappedBmp(Handle: HBITMAP; const ColorMap; NumMaps: Integer): HBITMAP;
  892. function CreateSysMappedBmp(Handle: HBITMAP): HBITMAP;
  893. function CreateMappedRes(Instance: THandle; ResName: PChar; const ColorMap;
  894.   NumMaps: Integer): HBITMAP;
  895. function CreateSysMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
  896.  
  897. function GetDefFontCharSet: TFontCharSet;
  898.  
  899. implementation
  900.  
  901. { Things left out
  902.   ---------------
  903.   Regions
  904.   PatBlt
  905.   Tabbed text
  906.   Clipping regions
  907.   Coordinate transformations
  908.   Paths
  909.   Beziers }
  910.  
  911. uses Consts;
  912.  
  913. const
  914.   csAllValid = [csHandleValid..csBrushValid];
  915.  
  916. var
  917.   ScreenLogPixels: Integer;
  918.   StockPen: HPEN;
  919.   StockBrush: HBRUSH;
  920.   StockFont: HFONT;
  921.   StockIcon: HICON;
  922.   BitmapImageLock: TRTLCriticalSection;
  923.   MonoBmp: TBitmap = nil;
  924.   DevBmp: TBitmap = nil;
  925.  
  926. procedure InternalDeletePalette(Pal: HPalette);
  927. begin
  928.   if (Pal <> 0) and (Pal <> SystemPalette16) then
  929.     DeleteObject(Pal);
  930. end;
  931.  
  932. { Resource managers }
  933.  
  934. const
  935.   ResInfoSize = SizeOf(TResource) - SizeOf(TFontData);
  936.  
  937. type
  938.   TResourceManager = class(TObject)
  939.     ResList: PResource;
  940.     FLock: TRTLCriticalSection;
  941.     ResDataSize: Word;
  942.     constructor Create(AResDataSize: Word);
  943.     destructor Destroy; override;
  944.     function AllocResource(const ResData): PResource;
  945.     procedure FreeResource(Resource: PResource);
  946.     procedure ChangeResource(GraphicsObject: TGraphicsObject; const ResData);
  947.     procedure AssignResource(GraphicsObject: TGraphicsObject;
  948.       AResource: PResource);
  949.     procedure Lock;
  950.     procedure Unlock;
  951.   end;
  952.  
  953. var
  954.   FontManager: TResourceManager;
  955.   PenManager: TResourceManager;
  956.   BrushManager: TResourceManager;
  957.  
  958. function GetHashCode(const Buffer; Count: Integer): Word; assembler;
  959. asm
  960.         MOV     ECX,EDX
  961.         MOV     EDX,EAX
  962.         XOR     EAX,EAX
  963. @@1:    ROL     AX,5
  964.         XOR     AL,[EDX]
  965.         INC     EDX
  966.         DEC     ECX
  967.         JNE     @@1
  968. end;
  969.  
  970. constructor TResourceManager.Create(AResDataSize: Word);
  971. begin
  972.   ResDataSize := AResDataSize;
  973.   InitializeCriticalSection(FLock);
  974. end;
  975.  
  976. destructor TResourceManager.Destroy;
  977. begin
  978.   DeleteCriticalSection(FLock);
  979. end;
  980.  
  981. procedure TResourceManager.Lock;
  982. begin
  983.   EnterCriticalSection(FLock);
  984. end;
  985.  
  986. procedure TResourceManager.Unlock;
  987. begin
  988.   LeaveCriticalSection(FLock);
  989. end;
  990.  
  991. function TResourceManager.AllocResource(const ResData): PResource;
  992. var
  993.   ResHash: Word;
  994. begin
  995.   ResHash := GetHashCode(ResData, ResDataSize);
  996.   Lock;
  997.   try
  998.     Result := ResList;
  999.     while (Result <> nil) and ((Result^.HashCode <> ResHash) or
  1000.       not CompareMem(@Result^.Data, @ResData, ResDataSize)) do
  1001.       Result := Result^.Next;
  1002.     if Result = nil then
  1003.     begin
  1004.       GetMem(Result, ResDataSize + ResInfoSize);
  1005.       with Result^ do
  1006.       begin
  1007.         Next := ResList;
  1008.         RefCount := 0;
  1009.         Handle := TResData(ResData).Handle;
  1010.         HashCode := ResHash;
  1011.         Move(ResData, Data, ResDataSize);
  1012.       end;
  1013.       ResList := Result;
  1014.     end;
  1015.     Inc(Result^.RefCount);
  1016.   finally
  1017.     Unlock;
  1018.   end;
  1019. end;
  1020.  
  1021. procedure TResourceManager.FreeResource(Resource: PResource);
  1022. var
  1023.   P: PResource;
  1024.   DeleteIt: Boolean;
  1025. begin
  1026.   if Resource <> nil then
  1027.     with Resource^ do
  1028.     begin
  1029.       Lock;
  1030.       try
  1031.         Dec(RefCount);
  1032.         DeleteIt := RefCount = 0;
  1033.         if DeleteIt then
  1034.         begin
  1035.           if Resource = ResList then
  1036.             ResList := Resource^.Next
  1037.           else
  1038.           begin
  1039.             P := ResList;
  1040.             while P^.Next <> Resource do P := P^.Next;
  1041.             P^.Next := Resource^.Next;
  1042.           end;
  1043.         end;
  1044.       finally
  1045.         Unlock;
  1046.       end;
  1047.       if DeleteIt then
  1048.       begin  // this is outside the critsect to minimize lock time
  1049.         if Handle <> 0 then DeleteObject(Handle);
  1050.         FreeMem(Resource);
  1051.       end;
  1052.     end;
  1053. end;
  1054.  
  1055. procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
  1056.   const ResData);
  1057. var
  1058.   P: PResource;
  1059. begin
  1060.   Lock;
  1061.   try  // prevent changes to GraphicsObject.FResource pointer between steps
  1062.     P := GraphicsObject.FResource;
  1063.     GraphicsObject.FResource := AllocResource(ResData);
  1064.     if GraphicsObject.FResource <> P then GraphicsObject.Changed;
  1065.     FreeResource(P);
  1066.   finally
  1067.     Unlock;
  1068.   end;
  1069. end;
  1070.  
  1071. procedure TResourceManager.AssignResource(GraphicsObject: TGraphicsObject;
  1072.   AResource: PResource);
  1073. var
  1074.   P: PResource;
  1075. begin
  1076.   Lock;
  1077.   try
  1078.     P := GraphicsObject.FResource;
  1079.     if P <> AResource then
  1080.     begin
  1081.       Inc(AResource^.RefCount);
  1082.       GraphicsObject.FResource := AResource;
  1083.       GraphicsObject.Changed;
  1084.       FreeResource(P);
  1085.     end;
  1086.   finally
  1087.     Unlock;
  1088.   end;
  1089. end;
  1090.  
  1091. var
  1092.   CanvasList: TThreadList;
  1093.  
  1094. procedure PaletteChanged;
  1095.  
  1096.   procedure ClearColor(ResMan: TResourceManager);
  1097.   var
  1098.     Resource: PResource;
  1099.   begin
  1100.     ResMan.Lock;
  1101.     try
  1102.       Resource := ResMan.ResList;
  1103.       while Resource <> nil do
  1104.       begin
  1105.         with Resource^ do
  1106.         { Assumes Pen.Color and Brush.Color share the same location }
  1107.           if (Handle <> 0) and (Pen.Color < 0) then
  1108.           begin
  1109.             DeleteObject(Handle);
  1110.             Handle := 0;
  1111.           end;
  1112.         Resource := Resource^.Next;
  1113.       end;
  1114.     finally
  1115.       ResMan.Unlock;
  1116.     end;
  1117.   end;
  1118.  
  1119. var
  1120.   I,J: Integer;
  1121. begin
  1122.   { Called when the system palette has changed (WM_SYSCOLORCHANGE) }
  1123.   I := 0;
  1124.   with CanvasList.LockList do
  1125.   try
  1126.     while I < Count do
  1127.     begin
  1128.       with TCanvas(Items[I]) do
  1129.       begin
  1130.         Lock;
  1131.         Inc(I);
  1132.         DeselectHandles;
  1133.       end;
  1134.     end;
  1135.     ClearColor(PenManager);
  1136.     ClearColor(BrushManager);
  1137.   finally
  1138.     for J := 0 to I-1 do  // Only unlock the canvases we actually locked
  1139.       TCanvas(Items[J]).Unlock;
  1140.     CanvasList.UnlockList;
  1141.   end;
  1142. end;
  1143.  
  1144. { Color mapping routines }
  1145.  
  1146. const
  1147.   Colors: array[0..41] of TIdentMapEntry = (
  1148.     (Value: clBlack; Name: 'clBlack'),
  1149.     (Value: clMaroon; Name: 'clMaroon'),
  1150.     (Value: clGreen; Name: 'clGreen'),
  1151.     (Value: clOlive; Name: 'clOlive'),
  1152.     (Value: clNavy; Name: 'clNavy'),
  1153.     (Value: clPurple; Name: 'clPurple'),
  1154.     (Value: clTeal; Name: 'clTeal'),
  1155.     (Value: clGray; Name: 'clGray'),
  1156.     (Value: clSilver; Name: 'clSilver'),
  1157.     (Value: clRed; Name: 'clRed'),
  1158.     (Value: clLime; Name: 'clLime'),
  1159.     (Value: clYellow; Name: 'clYellow'),
  1160.     (Value: clBlue; Name: 'clBlue'),
  1161.     (Value: clFuchsia; Name: 'clFuchsia'),
  1162.     (Value: clAqua; Name: 'clAqua'),
  1163.     (Value: clWhite; Name: 'clWhite'),
  1164.     (Value: clScrollBar; Name: 'clScrollBar'),
  1165.     (Value: clBackground; Name: 'clBackground'),
  1166.     (Value: clActiveCaption; Name: 'clActiveCaption'),
  1167.     (Value: clInactiveCaption; Name: 'clInactiveCaption'),
  1168.     (Value: clMenu; Name: 'clMenu'),
  1169.     (Value: clWindow; Name: 'clWindow'),
  1170.     (Value: clWindowFrame; Name: 'clWindowFrame'),
  1171.     (Value: clMenuText; Name: 'clMenuText'),
  1172.     (Value: clWindowText; Name: 'clWindowText'),
  1173.     (Value: clCaptionText; Name: 'clCaptionText'),
  1174.     (Value: clActiveBorder; Name: 'clActiveBorder'),
  1175.     (Value: clInactiveBorder; Name: 'clInactiveBorder'),
  1176.     (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
  1177.     (Value: clHighlight; Name: 'clHighlight'),
  1178.     (Value: clHighlightText; Name: 'clHighlightText'),
  1179.     (Value: clBtnFace; Name: 'clBtnFace'),
  1180.     (Value: clBtnShadow; Name: 'clBtnShadow'),
  1181.     (Value: clGrayText; Name: 'clGrayText'),
  1182.     (Value: clBtnText; Name: 'clBtnText'),
  1183.     (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
  1184.     (Value: clBtnHighlight; Name: 'clBtnHighlight'),
  1185.     (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
  1186.     (Value: cl3DLight; Name: 'cl3DLight'),
  1187.     (Value: clInfoText; Name: 'clInfoText'),
  1188.     (Value: clInfoBk; Name: 'clInfoBk'),
  1189.     (Value: clNone; Name: 'clNone'));
  1190.  
  1191. function ColorToRGB(Color: TColor): Longint;
  1192. begin
  1193.   if Color < 0 then
  1194.     Result := GetSysColor(Color and $000000FF) else
  1195.     Result := Color;
  1196. end;
  1197.  
  1198. function ColorToString(Color: TColor): string;
  1199. begin
  1200.   if not ColorToIdent(Color, Result) then
  1201.     FmtStr(Result, '$%.8x', [Color]);
  1202. end;
  1203.  
  1204. function StringToColor(const S: string): TColor;
  1205. begin
  1206.   if not IdentToColor(S, Longint(Result)) then
  1207.     Result := TColor(StrToInt(S));
  1208. end;
  1209.  
  1210. procedure GetColorValues(Proc: TGetStrProc);
  1211. var
  1212.   I: Integer;
  1213. begin
  1214.   for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name);
  1215. end;
  1216.  
  1217. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  1218. begin
  1219.   Result := IntToIdent(Color, Ident, Colors);
  1220. end;
  1221.  
  1222. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  1223. begin
  1224.   Result := IdentToInt(Ident, Color, Colors);
  1225. end;
  1226.  
  1227. { TGraphicsObject }
  1228.  
  1229. procedure TGraphicsObject.Changed;
  1230. begin
  1231.   if Assigned(FOnChange) then FOnChange(Self);
  1232. end;
  1233.  
  1234. procedure TGraphicsObject.Lock;
  1235. begin
  1236.   if Assigned(FOwnerLock) then EnterCriticalSection(FOwnerLock^);
  1237. end;
  1238.  
  1239. procedure TGraphicsObject.Unlock;
  1240. begin
  1241.   if Assigned(FOwnerLock) then LeaveCriticalSection(FOwnerLock^);
  1242. end;
  1243.  
  1244. { TFont }
  1245.  
  1246. const
  1247.   FontCharsets: array[0..17] of TIdentMapEntry = (
  1248.     (Value: 0; Name: 'ANSI_CHARSET'),
  1249.     (Value: 1; Name: 'DEFAULT_CHARSET'),
  1250.     (Value: 2; Name: 'SYMBOL_CHARSET'),
  1251.     (Value: 77; Name: 'MAC_CHARSET'),
  1252.     (Value: 128; Name: 'SHIFTJIS_CHARSET'),
  1253.     (Value: 129; Name: 'HANGEUL_CHARSET'),
  1254.     (Value: 130; Name: 'JOHAB_CHARSET'),
  1255.     (Value: 134; Name: 'GB2312_CHARSET'),
  1256.     (Value: 136; Name: 'CHINESEBIG5_CHARSET'),
  1257.     (Value: 161; Name: 'GREEK_CHARSET'),
  1258.     (Value: 162; Name: 'TURKISH_CHARSET'),
  1259.     (Value: 177; Name: 'HEBREW_CHARSET'),
  1260.     (Value: 178; Name: 'ARABIC_CHARSET'),
  1261.     (Value: 186; Name: 'BALTIC_CHARSET'),
  1262.     (Value: 204; Name: 'RUSSIAN_CHARSET'),
  1263.     (Value: 222; Name: 'THAI_CHARSET'),
  1264.     (Value: 238; Name: 'EASTEUROPE_CHARSET'),
  1265.     (Value: 255; Name: 'OEM_CHARSET'));
  1266.  
  1267. procedure GetCharsetValues(Proc: TGetStrProc);
  1268. var
  1269.   I: Integer;
  1270. begin
  1271.   for I := Low(FontCharsets) to High(FontCharsets) do Proc(FontCharsets[I].Name);
  1272. end;
  1273.  
  1274. function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
  1275. begin
  1276.   Result := IntToIdent(Charset, Ident, FontCharsets);
  1277. end;
  1278.  
  1279. function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
  1280. begin
  1281.   Result := IdentToInt(Ident, CharSet, FontCharsets);
  1282. end;
  1283.  
  1284. function GetFontData(Font: HFont): TFontData;
  1285. var
  1286.   LogFont: TLogFont;
  1287. begin
  1288.   Result := DefFontData;
  1289.   if Font <> 0 then
  1290.   begin
  1291.     if GetObject(Font, SizeOf(LogFont), @LogFont) <> 0 then
  1292.     with Result, LogFont do
  1293.     begin
  1294.       Height := lfHeight;
  1295.       if lfWeight >= FW_BOLD then
  1296.         Include(Style, fsBold);
  1297.       if lfItalic = 1 then
  1298.         Include(Style, fsItalic);
  1299.       if lfUnderline = 1 then
  1300.         Include(Style, fsUnderline);
  1301.       if lfStrikeOut = 1 then
  1302.         Include(Style, fsStrikeOut);
  1303.       Charset := TFontCharset(lfCharSet);
  1304.       Name := lfFaceName;
  1305.       case lfPitchAndFamily and $F of
  1306.         VARIABLE_PITCH: Pitch := fpVariable;
  1307.         FIXED_PITCH: Pitch := fpFixed;
  1308.       else
  1309.         Pitch := fpDefault;
  1310.       end;
  1311.       Handle := Font;
  1312.     end;
  1313.   end;
  1314. end;
  1315.  
  1316. constructor TFont.Create;
  1317. begin
  1318.   DefFontData.Handle := 0;
  1319.   FResource := FontManager.AllocResource(DefFontData);
  1320.   FColor := clWindowText;
  1321.   FPixelsPerInch := ScreenLogPixels;
  1322. end;
  1323.  
  1324. destructor TFont.Destroy;
  1325. begin
  1326.   FontManager.FreeResource(FResource);
  1327. end;
  1328.  
  1329. procedure TFont.Changed;
  1330. begin
  1331.   inherited Changed;
  1332.   if FNotify <> nil then FNotify.Changed;
  1333. end;
  1334.  
  1335. procedure TFont.Assign(Source: TPersistent);
  1336. begin
  1337.   if Source is TFont then
  1338.   begin
  1339.     Lock;
  1340.     try
  1341.       TFont(Source).Lock;
  1342.       try
  1343.         FontManager.AssignResource(Self, TFont(Source).FResource);
  1344.         Color := TFont(Source).Color;
  1345.         if PixelsPerInch <> TFont(Source).PixelsPerInch then
  1346.           Size := TFont(Source).Size;
  1347.       finally
  1348.         TFont(Source).Unlock;
  1349.       end;
  1350.     finally
  1351.       Unlock;
  1352.     end;
  1353.     Exit;
  1354.   end;
  1355.   inherited Assign(Source);
  1356. end;
  1357.  
  1358. procedure TFont.GetData(var FontData: TFontData);
  1359. begin
  1360.   FontData := FResource^.Font;
  1361.   FontData.Handle := 0;
  1362. end;
  1363.  
  1364. procedure TFont.SetData(const FontData: TFontData);
  1365. begin
  1366.   Lock;
  1367.   try
  1368.     FontManager.ChangeResource(Self, FontData);
  1369.   finally
  1370.     Unlock;
  1371.   end;
  1372. end;
  1373.  
  1374. procedure TFont.SetColor(Value: TColor);
  1375. begin
  1376.   if FColor <> Value then
  1377.   begin
  1378.     FColor := Value;
  1379.     Changed;
  1380.   end;
  1381. end;
  1382.  
  1383. function TFont.GetHandle: HFont;
  1384. var
  1385.   LogFont: TLogFont;
  1386. begin
  1387.   with FResource^ do
  1388.   begin
  1389.     if Handle = 0 then
  1390.     begin
  1391.       FontManager.Lock;
  1392.       with LogFont do
  1393.       try
  1394.         if Handle = 0 then
  1395.         begin
  1396.           lfHeight := Font.Height;
  1397.           lfWidth := 0; { have font mapper choose }
  1398.           lfEscapement := 0; { only straight fonts }
  1399.           lfOrientation := 0; { no rotation }
  1400.           if fsBold in Font.Style then
  1401.             lfWeight := FW_BOLD
  1402.           else
  1403.             lfWeight := FW_NORMAL;
  1404.           lfItalic := Byte(fsItalic in Font.Style);
  1405.           lfUnderline := Byte(fsUnderline in Font.Style);
  1406.           lfStrikeOut := Byte(fsStrikeOut in Font.Style);
  1407.           lfCharSet := Byte(Font.Charset);
  1408.           if CompareText(Font.Name, 'Default') = 0 then  // do not localize
  1409.             StrPCopy(lfFaceName, DefFontData.Name)
  1410.           else
  1411.             StrPCopy(lfFaceName, Font.Name);
  1412.           lfQuality := DEFAULT_QUALITY;
  1413.           { Everything else as default }
  1414.           lfOutPrecision := OUT_DEFAULT_PRECIS;
  1415.           lfClipPrecision := CLIP_DEFAULT_PRECIS;
  1416.           case Pitch of
  1417.             fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
  1418.             fpFixed: lfPitchAndFamily := FIXED_PITCH;
  1419.           else
  1420.             lfPitchAndFamily := DEFAULT_PITCH;
  1421.           end;
  1422.           Handle := CreateFontIndirect(LogFont);
  1423.         end;
  1424.       finally
  1425.         FontManager.Unlock;
  1426.       end;
  1427.     end;
  1428.     Result := Handle;
  1429.   end;
  1430. end;
  1431.  
  1432. procedure TFont.SetHandle(Value: HFont);
  1433. begin
  1434.   SetData(GetFontData(Value));
  1435. end;
  1436.  
  1437. function TFont.GetHeight: Integer;
  1438. begin
  1439.   Result := FResource^.Font.Height;
  1440. end;
  1441.  
  1442. procedure TFont.SetHeight(Value: Integer);
  1443. var
  1444.   FontData: TFontData;
  1445. begin
  1446.   GetData(FontData);
  1447.   FontData.Height := Value;
  1448.   SetData(FontData);
  1449. end;
  1450.  
  1451. function TFont.GetName: TFontName;
  1452. begin
  1453.   Result := FResource^.Font.Name;
  1454. end;
  1455.  
  1456. procedure TFont.SetName(const Value: TFontName);
  1457. var
  1458.   FontData: TFontData;
  1459. begin
  1460.   if Value <> '' then
  1461.   begin
  1462.     GetData(FontData);
  1463.     FillChar(FontData.Name, SizeOf(FontData.Name), 0);
  1464.     FontData.Name := Value;
  1465.     SetData(FontData);
  1466.   end;
  1467. end;
  1468.  
  1469. function TFont.GetSize: Integer;
  1470. begin
  1471.   Result := -MulDiv(Height, 72, FPixelsPerInch);
  1472. end;
  1473.  
  1474. procedure TFont.SetSize(Value: Integer);
  1475. begin
  1476.   Height := -MulDiv(Value, FPixelsPerInch, 72);
  1477. end;
  1478.  
  1479. function TFont.GetStyle: TFontStyles;
  1480. begin
  1481.   Result := FResource^.Font.Style;
  1482. end;
  1483.  
  1484. procedure TFont.SetStyle(Value: TFontStyles);
  1485. var
  1486.   FontData: TFontData;
  1487. begin
  1488.   GetData(FontData);
  1489.   FontData.Style := Value;
  1490.   SetData(FontData);
  1491. end;
  1492.  
  1493. function TFont.GetPitch: TFontPitch;
  1494. begin
  1495.   Result := FResource^.Font.Pitch;
  1496. end;
  1497.  
  1498. procedure TFont.SetPitch(Value: TFontPitch);
  1499. var
  1500.   FontData: TFontData;
  1501. begin
  1502.   GetData(FontData);
  1503.   FontData.Pitch := Value;
  1504.   SetData(FontData);
  1505. end;
  1506.  
  1507. function TFont.GetCharset: TFontCharset;
  1508. begin
  1509.   Result := FResource^.Font.Charset;
  1510. end;
  1511.  
  1512. procedure TFont.SetCharset(Value: TFontCharset);
  1513. var
  1514.   FontData: TFontData;
  1515. begin
  1516.   GetData(FontData);
  1517.   FontData.Charset := Value;
  1518.   SetData(FontData);
  1519. end;
  1520.  
  1521. { TPen }
  1522.  
  1523. const
  1524.   DefPenData: TPenData = (
  1525.     Handle: 0;
  1526.     Color: clBlack;
  1527.     Width: 1;
  1528.     Style: psSolid);
  1529.  
  1530. constructor TPen.Create;
  1531. begin
  1532.   FResource := PenManager.AllocResource(DefPenData);
  1533.   FMode := pmCopy;
  1534. end;
  1535.  
  1536. destructor TPen.Destroy;
  1537. begin
  1538.   PenManager.FreeResource(FResource);
  1539. end;
  1540.  
  1541. procedure TPen.Assign(Source: TPersistent);
  1542. begin
  1543.   if Source is TPen then
  1544.   begin
  1545.     Lock;
  1546.     try
  1547.       TPen(Source).Lock;
  1548.       try
  1549.         PenManager.AssignResource(Self, TPen(Source).FResource);
  1550.         SetMode(TPen(Source).FMode);
  1551.       finally
  1552.         TPen(Source).Unlock;
  1553.       end;
  1554.     finally
  1555.       Unlock;
  1556.     end;
  1557.     Exit;
  1558.   end;
  1559.   inherited Assign(Source);
  1560. end;
  1561.  
  1562. procedure TPen.GetData(var PenData: TPenData);
  1563. begin
  1564.   PenData := FResource^.Pen;
  1565.   PenData.Handle := 0;
  1566. end;
  1567.  
  1568. procedure TPen.SetData(const PenData: TPenData);
  1569. begin
  1570.   Lock;
  1571.   try
  1572.     PenManager.ChangeResource(Self, PenData);
  1573.   finally
  1574.     Unlock;
  1575.   end;
  1576. end;
  1577.  
  1578. function TPen.GetColor: TColor;
  1579. begin
  1580.   Result := FResource^.Pen.Color;
  1581. end;
  1582.  
  1583. procedure TPen.SetColor(Value: TColor);
  1584. var
  1585.   PenData: TPenData;
  1586. begin
  1587.   GetData(PenData);
  1588.   PenData.Color := Value;
  1589.   SetData(PenData);
  1590. end;
  1591.  
  1592. function TPen.GetHandle: HPen;
  1593. const
  1594.   PenStyles: array[TPenStyle] of Word =
  1595.     (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
  1596.      PS_INSIDEFRAME);
  1597. var
  1598.   LogPen: TLogPen;
  1599. begin
  1600.   with FResource^ do
  1601.   begin
  1602.     if Handle = 0 then
  1603.     begin
  1604.       PenManager.Lock;
  1605.       with LogPen do
  1606.       try
  1607.         if Handle = 0 then
  1608.         begin
  1609.           lopnStyle := PenStyles[Pen.Style];
  1610.           lopnWidth.X := Pen.Width;
  1611.           lopnColor := ColorToRGB(Pen.Color);
  1612.           Handle := CreatePenIndirect(LogPen);
  1613.         end;
  1614.       finally
  1615.         PenManager.Unlock;
  1616.       end;
  1617.     end;
  1618.     Result := Handle;
  1619.   end;
  1620. end;
  1621.  
  1622. procedure TPen.SetHandle(Value: HPen);
  1623. var
  1624.   PenData: TPenData;
  1625. begin
  1626.   PenData := DefPenData;
  1627.   PenData.Handle := Value;
  1628.   SetData(PenData);
  1629. end;
  1630.  
  1631. procedure TPen.SetMode(Value: TPenMode);
  1632. begin
  1633.   if FMode <> Value then
  1634.   begin
  1635.     FMode := Value;
  1636.     Changed;
  1637.   end;
  1638. end;
  1639.  
  1640. function TPen.GetStyle: TPenStyle;
  1641. begin
  1642.   Result := FResource^.Pen.Style;
  1643. end;
  1644.  
  1645. procedure TPen.SetStyle(Value: TPenStyle);
  1646. var
  1647.   PenData: TPenData;
  1648. begin
  1649.   GetData(PenData);
  1650.   PenData.Style := Value;
  1651.   SetData(PenData);
  1652. end;
  1653.  
  1654. function TPen.GetWidth: Integer;
  1655. begin
  1656.   Result := FResource^.Pen.Width;
  1657. end;
  1658.  
  1659. procedure TPen.SetWidth(Value: Integer);
  1660. var
  1661.   PenData: TPenData;
  1662. begin
  1663.   if Value >= 0 then
  1664.   begin
  1665.     GetData(PenData);
  1666.     PenData.Width := Value;
  1667.     SetData(PenData);
  1668.   end;
  1669. end;
  1670.  
  1671. { TBrush }
  1672.  
  1673. const
  1674.   DefBrushData: TBrushData = (
  1675.     Handle: 0;
  1676.     Color: clWhite;
  1677.     Bitmap: nil;
  1678.     Style: bsSolid);
  1679.  
  1680. constructor TBrush.Create;
  1681. begin
  1682.   FResource := BrushManager.AllocResource(DefBrushData);
  1683. end;
  1684.  
  1685. destructor TBrush.Destroy;
  1686. begin
  1687.   BrushManager.FreeResource(FResource);
  1688. end;
  1689.  
  1690. procedure TBrush.Assign(Source: TPersistent);
  1691. begin
  1692.   if Source is TBrush then
  1693.   begin
  1694.     Lock;
  1695.     try
  1696.       TBrush(Source).Lock;
  1697.       try
  1698.         BrushManager.AssignResource(Self, TBrush(Source).FResource);
  1699.       finally
  1700.         TBrush(Source).Unlock;
  1701.       end;
  1702.     finally
  1703.       Unlock;
  1704.     end;
  1705.     Exit;
  1706.   end;
  1707.   inherited Assign(Source);
  1708. end;
  1709.  
  1710. procedure TBrush.GetData(var BrushData: TBrushData);
  1711. begin
  1712.   BrushData := FResource^.Brush;
  1713.   BrushData.Handle := 0;
  1714.   BrushData.Bitmap := nil;
  1715. end;
  1716.  
  1717. procedure TBrush.SetData(const BrushData: TBrushData);
  1718. begin
  1719.   Lock;
  1720.   try
  1721.     BrushManager.ChangeResource(Self, BrushData);
  1722.   finally
  1723.     Unlock;
  1724.   end;
  1725. end;
  1726.  
  1727. function TBrush.GetBitmap: TBitmap;
  1728. begin
  1729.   Result := FResource^.Brush.Bitmap;
  1730. end;
  1731.  
  1732. procedure TBrush.SetBitmap(Value: TBitmap);
  1733. var
  1734.   BrushData: TBrushData;
  1735. begin
  1736.   BrushData := DefBrushData;
  1737.   BrushData.Bitmap := Value;
  1738.   SetData(BrushData);
  1739. end;
  1740.  
  1741. function TBrush.GetColor: TColor;
  1742. begin
  1743.   Result := FResource^.Brush.Color;
  1744. end;
  1745.  
  1746. procedure TBrush.SetColor(Value: TColor);
  1747. var
  1748.   BrushData: TBrushData;
  1749. begin
  1750.   GetData(BrushData);
  1751.   BrushData.Color := Value;
  1752.   if BrushData.Style = bsClear then BrushData.Style := bsSolid;
  1753.   SetData(BrushData);
  1754. end;
  1755.  
  1756. function TBrush.GetHandle: HBrush;
  1757. var
  1758.   LogBrush: TLogBrush;
  1759. begin
  1760.   with FResource^ do
  1761.   begin
  1762.     if Handle = 0 then
  1763.     begin
  1764.       BrushManager.Lock;
  1765.       try
  1766.         if Handle = 0 then
  1767.         begin
  1768.           with LogBrush do
  1769.           begin
  1770.             if Brush.Bitmap <> nil then
  1771.             begin
  1772.               lbStyle := BS_PATTERN;
  1773.               Brush.Bitmap.HandleType := bmDDB;
  1774.               lbHatch := Brush.Bitmap.Handle;
  1775.             end else
  1776.             begin
  1777.               lbHatch := 0;
  1778.               case Brush.Style of
  1779.                 bsSolid: lbStyle := BS_SOLID;
  1780.                 bsClear: lbStyle := BS_HOLLOW;
  1781.               else
  1782.                 lbStyle := BS_HATCHED;
  1783.                 lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
  1784.               end;
  1785.             end;
  1786.             lbColor := ColorToRGB(Brush.Color);
  1787.           end;
  1788.           Handle := CreateBrushIndirect(LogBrush);
  1789.         end;
  1790.       finally
  1791.         BrushManager.Unlock;
  1792.       end;
  1793.     end;
  1794.     Result := Handle;
  1795.   end;
  1796. end;
  1797.  
  1798. procedure TBrush.SetHandle(Value: HBrush);
  1799. var
  1800.   BrushData: TBrushData;
  1801. begin
  1802.   BrushData := DefBrushData;
  1803.   BrushData.Handle := Value;
  1804.   SetData(BrushData);
  1805. end;
  1806.  
  1807. function TBrush.GetStyle: TBrushStyle;
  1808. begin
  1809.   Result := FResource^.Brush.Style;
  1810. end;
  1811.  
  1812. procedure TBrush.SetStyle(Value: TBrushStyle);
  1813. var
  1814.   BrushData: TBrushData;
  1815. begin
  1816.   GetData(BrushData);
  1817.   BrushData.Style := Value;
  1818.   if BrushData.Style = bsClear then BrushData.Color := clWhite;
  1819.   SetData(BrushData);
  1820. end;
  1821.  
  1822. { TCanvas }
  1823.  
  1824. constructor TCanvas.Create;
  1825. begin
  1826.   inherited Create;
  1827.   InitializeCriticalSection(FLock);
  1828.   FFont := TFont.Create;
  1829.   FFont.OnChange := FontChanged;
  1830.   FFont.OwnerCriticalSection := @FLock;
  1831.   FPen := TPen.Create;
  1832.   FPen.OnChange := PenChanged;
  1833.   FPen.OwnerCriticalSection := @FLock;
  1834.   FBrush := TBrush.Create;
  1835.   FBrush.OnChange := BrushChanged;
  1836.   FBrush.OwnerCriticalSection := @FLock;
  1837.   FCopyMode := cmSrcCopy;
  1838.   State := [];
  1839.   CanvasList.Add(Self);
  1840. end;
  1841.  
  1842. destructor TCanvas.Destroy;
  1843. begin
  1844.   CanvasList.Remove(Self);
  1845.   SetHandle(0);
  1846.   FFont.Free;
  1847.   FPen.Free;
  1848.   FBrush.Free;
  1849.   DeleteCriticalSection(FLock);
  1850.   inherited Destroy;
  1851. end;
  1852.  
  1853. procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1854. begin
  1855.   Changing;
  1856.   RequiredState([csHandleValid, csPenValid]);
  1857.   Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1858.   Changed;
  1859. end;
  1860.  
  1861. procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  1862.   const Source: TRect; Color: TColor);
  1863. const
  1864.   ROP_DSPDxax = $00E20746;
  1865. var
  1866.   W, H: Integer;
  1867. //  I: Integer;
  1868. //  SaveColor, NewColor: TRGBQuad;
  1869.   crBack, crText: TColorRef;
  1870.   TempOrg: TPoint;
  1871.   Temp: TBitmap;
  1872. begin
  1873.   if Bitmap = nil then Exit;
  1874.   Lock;
  1875.   try
  1876.     Changing;
  1877.     RequiredState([csHandleValid, csBrushValid]);
  1878.     Bitmap.Canvas.Lock;
  1879.     try
  1880.       Bitmap.Canvas.RequiredState([csHandleValid]);
  1881. {      if (Bitmap.HandleType = bmDIB) and (Bitmap.FImage.FDIB.dsbmih.biBitCount <= 8)
  1882.         and (Brush.Style = bsSolid) then
  1883.       begin
  1884.         I := GetNearestPaletteIndex(Bitmap.Palette, Color);
  1885.         GetDIBColorTable(Bitmap.Canvas.FHandle, I, 1, SaveColor);
  1886.         crBack := ColorToRGB(Brush.Color);
  1887.         with NewColor do
  1888.         begin
  1889.           rgbRed := GetRValue(crBack);
  1890.           rgbGreen := GetGValue(crBack);
  1891.           rgbBlue := GetBValue(crBack);
  1892.           rgbReserved := 0;
  1893.         end;
  1894.         SetDIBColorTable(Bitmap.Canvas.FHandle, I, 1, NewColor);
  1895.         try
  1896.           StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
  1897.             Dest.Bottom - Dest.Top, Bitmap.Canvas.FHandle, Source.Left, Source.Top,
  1898.             W, H, SrcCopy);
  1899.         finally
  1900.           SetDIBColorTable(Bitmap.Canvas.FHandle, I, 1, SaveColor);
  1901.         end;
  1902.       end
  1903.       else
  1904. }      begin       // Build a mask and paint through it
  1905.         if (MonoBmp = nil) or (DevBmp = nil) then
  1906.         begin
  1907.           EnterCriticalSection(BitmapImageLock);
  1908.           try
  1909.             if MonoBmp = nil then
  1910.             begin
  1911.               MonoBmp := TBitmap.Create;
  1912.               MonoBmp.Monochrome := True;
  1913.             end;
  1914.             if DevBmp = nil then
  1915.             begin
  1916.               DevBmp := TBitmap.Create;
  1917.               DevBmp.HandleType := bmDDB;
  1918.             end;
  1919.           finally
  1920.             LeaveCriticalSection(BitmapImageLock);
  1921.           end;
  1922.         end;
  1923.         MonoBmp.Canvas.Lock;
  1924.         try
  1925.           W := Dest.Right - Dest.Left;
  1926.           H := Dest.Bottom - Dest.Top;
  1927.           if W > MonoBmp.Width then MonoBmp.Width := W;
  1928.           if H > MonoBmp.Height then MonoBmp.Height := H;
  1929.           MonoBmp.Canvas.RequiredState([csHandleValid]);
  1930.  
  1931.           Temp := Bitmap;
  1932.           TempOrg := Source.TopLeft;
  1933.           try
  1934.             if Bitmap.HandleType = bmDIB then
  1935.             begin
  1936.               Temp := TBitmap.Create;
  1937.               Temp.Assign(Bitmap);
  1938.               Temp.HandleType := bmDDB;
  1939.               TempOrg.X := 0;
  1940.               TempOrg.Y := 0;
  1941.             end;
  1942.  
  1943.             Temp.Canvas.RequiredState([csHandleValid]);
  1944.             SetBkColor(Temp.Canvas.FHandle, ColorToRGB(Color));
  1945.             BitBlt(MonoBmp.Canvas.FHandle, 0, 0, W, H,
  1946.               Temp.Canvas.FHandle, TempOrg.X, TempOrg.Y, SrcCopy);
  1947.  
  1948.             StretchBlt(FHandle, Dest.Left, Dest.Top, W, H,
  1949.               Temp.Canvas.FHandle, TempOrg.X, TempOrg.Y,
  1950.               Source.Right - Source.Left, Source.Bottom - Source.Top, SrcCopy);
  1951.           finally
  1952.             if Temp <> Bitmap then Temp.Free;
  1953.           end;
  1954.  
  1955.           crText := SetTextColor(FHandle, 0);
  1956.           crBack := SetBkColor(FHandle, $FFFFFF);
  1957.           BitBlt(FHandle, Dest.Left, Dest.Top, W, H,
  1958.             MonoBmp.Canvas.FHandle, 0, 0, ROP_DSPDxax);
  1959.           SetTextColor(FHandle, crText);
  1960.           SetBkColor(FHandle, crBack);
  1961.         finally
  1962.           MonoBmp.Canvas.Unlock;
  1963.         end;
  1964.       end;
  1965.     finally
  1966.       Bitmap.Canvas.Unlock;
  1967.     end;
  1968.     Changed;
  1969.   finally
  1970.     Unlock;
  1971.   end;
  1972. end;
  1973.  
  1974. procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1975. begin
  1976.   Changing;
  1977.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1978.   Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1979.   Changed;
  1980. end;
  1981.  
  1982. procedure TCanvas.CopyRect(const Dest: TRect; Canvas: TCanvas;
  1983.   const Source: TRect);
  1984. begin
  1985.   Changing;
  1986.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  1987.   Canvas.RequiredState([csHandleValid, csBrushValid]);
  1988.   StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
  1989.     Dest.Bottom - Dest.Top, Canvas.FHandle, Source.Left, Source.Top,
  1990.     Source.Right - Source.Left, Source.Bottom - Source.Top, CopyMode);
  1991.   Changed;
  1992. end;
  1993.  
  1994. procedure TCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
  1995. begin
  1996.   if (Graphic <> nil) and not Graphic.Empty then
  1997.   begin
  1998.     Changing;
  1999.     RequiredState([csHandleValid]);
  2000.     SetBkColor(FHandle, ColorToRGB(FBrush.Color));
  2001.     SetTextColor(FHandle, ColorToRGB(FFont.Color));
  2002.     Graphic.Draw(Self, Rect(X, Y, X + Graphic.Width, Y + Graphic.Height));
  2003.     Changed;
  2004.   end;
  2005. end;
  2006.  
  2007. procedure TCanvas.DrawFocusRect(const Rect: TRect);
  2008. begin
  2009.   Changing;
  2010.   RequiredState([csHandleValid, csBrushValid]);
  2011.   Windows.DrawFocusRect(FHandle, Rect);
  2012.   Changed;
  2013. end;
  2014.  
  2015. procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
  2016. begin
  2017.   Changing;
  2018.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2019.   Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
  2020.   Changed;
  2021. end;
  2022.  
  2023. procedure TCanvas.FillRect(const Rect: TRect);
  2024. begin
  2025.   Changing;
  2026.   RequiredState([csHandleValid, csBrushValid]);
  2027.   Windows.FillRect(FHandle, Rect, Brush.GetHandle);
  2028.   Changed;
  2029. end;
  2030.  
  2031. procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
  2032.   FillStyle: TFillStyle);
  2033. const
  2034.   FillStyles: array[TFillStyle] of Word =
  2035.     (FLOODFILLSURFACE, FLOODFILLBORDER);
  2036. begin
  2037.   Changing;
  2038.   RequiredState([csHandleValid, csBrushValid]);
  2039.   Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
  2040.   Changed;
  2041. end;
  2042.  
  2043. procedure TCanvas.FrameRect(const Rect: TRect);
  2044. begin
  2045.   Changing;
  2046.   RequiredState([csHandleValid, csBrushValid]);
  2047.   Windows.FrameRect(FHandle, Rect, Brush.GetHandle);
  2048.   Changed;
  2049. end;
  2050.  
  2051. procedure TCanvas.LineTo(X, Y: Integer);
  2052. begin
  2053.   Changing;
  2054.   RequiredState([csHandleValid, csPenValid]);
  2055.   Windows.LineTo(FHandle, X, Y);
  2056.   Changed;
  2057. end;
  2058.  
  2059. procedure TCanvas.Lock;
  2060. begin
  2061.   EnterCriticalSection(FLock);
  2062.   Inc(FLockCount);
  2063. end;
  2064.  
  2065. procedure TCanvas.MoveTo(X, Y: Integer);
  2066. begin
  2067.   RequiredState([csHandleValid]);
  2068.   Windows.MoveToEx(FHandle, X, Y, nil);
  2069. end;
  2070.  
  2071. procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  2072. begin
  2073.   Changing;
  2074.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2075.   Windows.Pie(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  2076.   Changed;
  2077. end;
  2078.  
  2079. type
  2080.   PPoints = ^TPoints;
  2081.   TPoints = array[0..0] of TPoint;
  2082.  
  2083. procedure TCanvas.Polygon(const Points: array of TPoint);
  2084. begin
  2085.   Changing;
  2086.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2087.   Windows.Polygon(FHandle, PPoints(@Points)^, High(Points) + 1);
  2088.   Changed;
  2089. end;
  2090.  
  2091. procedure TCanvas.Polyline(const Points: array of TPoint);
  2092. begin
  2093.   Changing;
  2094.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2095.   Windows.Polyline(FHandle, PPoints(@Points)^, High(Points) + 1);
  2096.   Changed;
  2097. end;
  2098.  
  2099. procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
  2100. begin
  2101.   Changing;
  2102.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  2103.   Windows.Rectangle(FHandle, X1, Y1, X2, Y2);
  2104.   Changed;
  2105. end;
  2106.  
  2107. procedure TCanvas.Refresh;
  2108. begin
  2109.   DeselectHandles;
  2110. end;
  2111.  
  2112. procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  2113. begin
  2114.   Changing;
  2115.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  2116.   Windows.RoundRect(FHandle, X1, Y1, X2, Y2, X3, Y3);
  2117.   Changed;
  2118. end;
  2119.  
  2120. procedure TCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
  2121. begin
  2122.   if Graphic <> nil then
  2123.   begin
  2124.     Changing;
  2125.     RequiredState(csAllValid);
  2126.     Graphic.Draw(Self, Rect);
  2127.     Changed;
  2128.   end;
  2129. end;
  2130.  
  2131. procedure TCanvas.TextOut(X, Y: Integer; const Text: String);
  2132. begin
  2133.   Changing;
  2134.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  2135.   Windows.TextOut(FHandle, X, Y, PChar(Text), Length(Text));
  2136.   MoveTo(X + TextWidth(Text), Y);
  2137.   Changed;
  2138. end;
  2139.  
  2140. procedure TCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  2141. var
  2142.   Options: Integer;
  2143. begin
  2144.   Changing;
  2145.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  2146.   Options := ETO_CLIPPED;
  2147.   if Brush.Style <> bsClear then Inc(Options, ETO_OPAQUE);
  2148.   Windows.ExtTextOut(FHandle, X, Y, Options, @Rect, PChar(Text),
  2149.     Length(Text), nil);
  2150.   Changed;
  2151. end;
  2152.  
  2153. function TCanvas.TextExtent(const Text: string): TSize;
  2154. begin
  2155.   RequiredState([csHandleValid, csFontValid]);
  2156.   Result.cX := 0;
  2157.   Result.cY := 0;
  2158.   Windows.GetTextExtentPoint(FHandle, PChar(Text), Length(Text), Result);
  2159. end;
  2160.  
  2161. function TCanvas.TextWidth(const Text: string): Integer;
  2162. begin
  2163.   Result := TextExtent(Text).cX;
  2164. end;
  2165.  
  2166. function TCanvas.TextHeight(const Text: string): Integer;
  2167. begin
  2168.   Result := TextExtent(Text).cY;
  2169. end;
  2170.  
  2171. procedure TCanvas.Unlock;
  2172. begin
  2173.   Dec(FLockCount);
  2174.   LeaveCriticalSection(FLock);
  2175. end;
  2176.  
  2177. procedure TCanvas.SetFont(Value: TFont);
  2178. begin
  2179.   FFont.Assign(Value);
  2180. end;
  2181.  
  2182. procedure TCanvas.SetPen(Value: TPen);
  2183. begin
  2184.   FPen.Assign(Value);
  2185. end;
  2186.  
  2187. procedure TCanvas.SetBrush(Value: TBrush);
  2188. begin
  2189.   FBrush.Assign(Value);
  2190. end;
  2191.  
  2192. function TCanvas.GetPenPos: TPoint;
  2193. begin
  2194.   RequiredState([csHandleValid]);
  2195.   Windows.GetCurrentPositionEx(FHandle, @Result);
  2196. end;
  2197.  
  2198. procedure TCanvas.SetPenPos(Value: TPoint);
  2199. begin
  2200.   MoveTo(Value.X, Value.Y);
  2201. end;
  2202.  
  2203. function TCanvas.GetPixel(X, Y: Integer): TColor;
  2204. begin
  2205.   RequiredState([csHandleValid]);
  2206.   GetPixel := Windows.GetPixel(FHandle, X, Y);
  2207. end;
  2208.  
  2209. procedure TCanvas.SetPixel(X, Y: Integer; Value: TColor);
  2210. begin
  2211.   Changing;
  2212.   RequiredState([csHandleValid, csPenValid]);
  2213.   Windows.SetPixel(FHandle, X, Y, ColorToRGB(Value));
  2214.   Changed;
  2215. end;
  2216.  
  2217. function TCanvas.GetClipRect: TRect;
  2218. begin
  2219.   RequiredState([csHandleValid]);
  2220.   GetClipBox(FHandle, Result);
  2221. end;
  2222.  
  2223. function TCanvas.GetHandle: HDC;
  2224. begin
  2225.   Changing;
  2226.   RequiredState(csAllValid);
  2227.   Result := FHandle;
  2228. end;
  2229.  
  2230. procedure TCanvas.DeselectHandles;
  2231. begin
  2232.   if (FHandle <> 0) and (State - [csPenValid, csBrushValid, csFontValid] <> State) then
  2233.   begin
  2234.     SelectObject(FHandle, StockPen);
  2235.     SelectObject(FHandle, StockBrush);
  2236.     SelectObject(FHandle, StockFont);
  2237.     State := State - [csPenValid, csBrushValid, csFontValid];
  2238.   end;
  2239. end;
  2240.  
  2241. procedure TCanvas.CreateHandle;
  2242. begin
  2243. end;
  2244.  
  2245. procedure TCanvas.SetHandle(Value: HDC);
  2246. begin
  2247.   if FHandle <> Value then
  2248.   begin
  2249.     if FHandle <> 0 then
  2250.     begin
  2251.       DeselectHandles;
  2252.       FPenPos := GetPenPos;
  2253.       FHandle := 0;
  2254.       Exclude(State, csHandleValid);
  2255.     end;
  2256.     if Value <> 0 then
  2257.     begin
  2258.       Include(State, csHandleValid);
  2259.       FHandle := Value;
  2260.       SetPenPos(FPenPos);
  2261.     end;
  2262.   end;
  2263. end;
  2264.  
  2265. procedure TCanvas.RequiredState(ReqState: TCanvasState);
  2266. var
  2267.   NeededState: TCanvasState;
  2268. begin
  2269.   NeededState := ReqState - State;
  2270.   if NeededState <> [] then
  2271.   begin
  2272.     if csHandleValid in NeededState then
  2273.     begin
  2274.       CreateHandle;
  2275.       if FHandle = 0 then
  2276.         raise EInvalidOperation.Create(SNoCanvasHandle);
  2277.     end;
  2278.     if csFontValid in NeededState then CreateFont;
  2279.     if csPenValid in NeededState then
  2280.     begin
  2281.       CreatePen;
  2282.       if Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
  2283.         Include(NeededState, csBrushValid);
  2284.     end;
  2285.     if csBrushValid in NeededState then CreateBrush;
  2286.     State := State + NeededState;
  2287.   end;
  2288. end;
  2289.  
  2290. procedure TCanvas.Changing;
  2291. begin
  2292.   if Assigned(FOnChanging) then FOnChanging(Self);
  2293. end;
  2294.  
  2295. procedure TCanvas.Changed;
  2296. begin
  2297.   if Assigned(FOnChange) then FOnChange(Self);
  2298. end;
  2299.  
  2300. procedure TCanvas.CreateFont;
  2301. begin
  2302.   SelectObject(FHandle, Font.GetHandle);
  2303.   SetTextColor(FHandle, ColorToRGB(Font.Color));
  2304. end;
  2305.  
  2306. procedure TCanvas.CreatePen;
  2307. const
  2308.   PenModes: array[TPenMode] of Word =
  2309.     (R2_BLACK, R2_WHITE, R2_NOP, R2_NOT, R2_COPYPEN, R2_NOTCOPYPEN, R2_MERGEPENNOT,
  2310.      R2_MASKPENNOT, R2_MERGENOTPEN, R2_MASKNOTPEN, R2_MERGEPEN, R2_NOTMERGEPEN,
  2311.      R2_MASKPEN, R2_NOTMASKPEN, R2_XORPEN, R2_NOTXORPEN);
  2312. begin
  2313.   SelectObject(FHandle, Pen.GetHandle);
  2314.   SetROP2(FHandle, PenModes[Pen.Mode]);
  2315. end;
  2316.  
  2317. procedure TCanvas.CreateBrush;
  2318. begin
  2319.   UnrealizeObject(Brush.Handle);
  2320.   SelectObject(FHandle, Brush.Handle);
  2321.   if Brush.Style = bsSolid then
  2322.   begin
  2323.     SetBkColor(FHandle, ColorToRGB(Brush.Color));
  2324.     SetBkMode(FHandle, OPAQUE);
  2325.   end
  2326.   else
  2327.   begin
  2328.     { Win95 doesn't draw brush hatches if bkcolor = brush color }
  2329.     { Since bkmode is transparent, nothing should use bkcolor anyway }
  2330.     SetBkColor(FHandle, not ColorToRGB(Brush.Color));
  2331.     SetBkMode(FHandle, TRANSPARENT);
  2332.   end;
  2333. end;
  2334.  
  2335. procedure TCanvas.FontChanged(AFont: TObject);
  2336. begin
  2337.   if csFontValid in State then
  2338.   begin
  2339.     Exclude(State, csFontValid);
  2340.     SelectObject(FHandle, StockFont);
  2341.   end;
  2342. end;
  2343.  
  2344. procedure TCanvas.PenChanged(APen: TObject);
  2345. begin
  2346.   if csPenValid in State then
  2347.   begin
  2348.     Exclude(State, csPenValid);
  2349.     SelectObject(FHandle, StockPen);
  2350.   end;
  2351. end;
  2352.  
  2353. procedure TCanvas.BrushChanged(ABrush: TObject);
  2354. begin
  2355.   if csBrushValid in State then
  2356.   begin
  2357.     Exclude(State, csBrushValid);
  2358.     SelectObject(FHandle, StockBrush);
  2359.   end;
  2360. end;
  2361.  
  2362. { Picture support }
  2363.  
  2364. { Icon and cursor types }
  2365.  
  2366. const
  2367.   rc3_StockIcon = 0;
  2368.   rc3_Icon = 1;
  2369.   rc3_Cursor = 2;
  2370.  
  2371. type
  2372.   PCursorOrIcon = ^TCursorOrIcon;
  2373.   TCursorOrIcon = packed record
  2374.     Reserved: Word;
  2375.     wType: Word;
  2376.     Count: Word;
  2377.   end;
  2378.  
  2379.   PIconRec = ^TIconRec;
  2380.   TIconRec = packed record
  2381.     Width: Byte;
  2382.     Height: Byte;
  2383.     Colors: Word;
  2384.     Reserved1: Word;
  2385.     Reserved2: Word;
  2386.     DIBSize: Longint;
  2387.     DIBOffset: Longint;
  2388.   end;
  2389.  
  2390.  
  2391. { Metafile types }
  2392.  
  2393. const
  2394.   WMFKey = $9AC6CDD7;
  2395.   WMFWord = $CDD7;
  2396.  
  2397. type
  2398.   PMetafileHeader = ^TMetafileHeader;
  2399.   TMetafileHeader = packed record
  2400.     Key: Longint;
  2401.     Handle: SmallInt;
  2402.     Box: TSmallRect;
  2403.     Inch: Word;
  2404.     Reserved: Longint;
  2405.     CheckSum: Word;
  2406.   end;
  2407.  
  2408. { Exception routines }
  2409.  
  2410. procedure InvalidOperation(const Str: string); near;
  2411. begin
  2412.   raise EInvalidGraphicOperation.Create(Str);
  2413. end;
  2414.  
  2415. procedure InvalidGraphic(const Str: string); near;
  2416. begin
  2417.   raise EInvalidGraphic.Create(Str);
  2418. end;
  2419.  
  2420. procedure InvalidBitmap; near;
  2421. begin
  2422.   InvalidGraphic(SInvalidBitmap);
  2423. end;
  2424.  
  2425. procedure InvalidIcon;
  2426. begin
  2427.   InvalidGraphic(SInvalidIcon);
  2428. end;
  2429.  
  2430. procedure InvalidMetafile;
  2431. begin
  2432.   InvalidGraphic(SInvalidMetafile);
  2433. end;
  2434.  
  2435. procedure OutOfResources;
  2436. begin
  2437.   raise EOutOfResources.Create(SOutOfResources);
  2438. end;
  2439.  
  2440. procedure GDIError;
  2441. var
  2442.   ErrorCode: Integer;
  2443.   Buf: array [Byte] of Char;
  2444. begin
  2445.   ErrorCode := GetLastError;
  2446.   if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
  2447.     ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
  2448.     raise EOutOfResources.Create(Buf)
  2449.   else
  2450.     OutOfResources;
  2451. end;
  2452.  
  2453. function GDICheck(Value: Integer): Integer;
  2454. begin
  2455.   if Value = 0 then GDIError;
  2456.   Result := Value;
  2457. end;
  2458.  
  2459. function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
  2460. var
  2461.   DC, Mem1, Mem2: HDC;
  2462.   Old1, Old2: HBITMAP;
  2463.   Bitmap: Windows.TBitmap;
  2464. begin
  2465.   Mem1 := CreateCompatibleDC(0);
  2466.   Mem2 := CreateCompatibleDC(0);
  2467.  
  2468.   try
  2469.     GetObject(Src, SizeOf(Bitmap), @Bitmap);
  2470.     if Mono then
  2471.       Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
  2472.     else
  2473.     begin
  2474.       DC := GetDC(0);
  2475.       if DC = 0 then GDIError;
  2476.       try
  2477.         Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
  2478.         if Result = 0 then GDIError;
  2479.       finally
  2480.         ReleaseDC(0, DC);
  2481.       end;
  2482.     end;
  2483.  
  2484.     if Result <> 0 then
  2485.     begin
  2486.       Old1 := SelectObject(Mem1, Src);
  2487.       Old2 := SelectObject(Mem2, Result);
  2488.  
  2489.       StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
  2490.         Bitmap.bmHeight, SrcCopy);
  2491.       if Old1 <> 0 then SelectObject(Mem1, Old1);
  2492.       if Old2 <> 0 then SelectObject(Mem2, Old2);
  2493.     end;
  2494.   finally
  2495.     DeleteDC(Mem1);
  2496.     DeleteDC(Mem2);
  2497.   end;
  2498. end;
  2499.  
  2500. function GetDInColors(BitCount: Word): Integer;
  2501. begin
  2502.   case BitCount of
  2503.     1, 4, 8: Result := 1 shl BitCount;
  2504.   else
  2505.     Result := 0;
  2506.   end;
  2507. end;
  2508.  
  2509. function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
  2510. begin
  2511.   Dec(Alignment);
  2512.   Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
  2513.   Result := Result div 8;
  2514. end;
  2515.  
  2516. type
  2517.   PRGBTripleArray = ^TRGBTripleArray;
  2518.   TRGBTripleArray = array [Byte] of TRGBTriple;
  2519.   PRGBQuadArray = ^TRGBQuadArray;
  2520.   TRGBQuadArray = array [Byte] of TRGBQuad;
  2521.  
  2522. { RGBTripleToQuad performs in-place conversion of an OS2 color
  2523.   table into a DIB color table.   }
  2524. procedure RGBTripleToQuad(var ColorTable);
  2525. var
  2526.   I: Integer;
  2527.   P3: PRGBTripleArray;
  2528.   P4: PRGBQuadArray;
  2529. begin
  2530.   P3 := PRGBTripleArray(@ColorTable);
  2531.   P4 := Pointer(P3);
  2532.   for I := 255 downto 1 do  // don't move zeroth item
  2533.     with P4^[I], P3^[I] do
  2534.     begin                     // order is significant for last item moved
  2535.       rgbRed := rgbtRed;
  2536.       rgbGreen := rgbtGreen;
  2537.       rgbBlue := rgbtBlue;
  2538.       rgbReserved := 0;
  2539.     end;
  2540. end;
  2541.  
  2542. { RGBQuadToTriple performs the inverse of RGBTripleToQuad. }
  2543. procedure RGBQuadToTriple(var ColorTable; var ColorCount: Integer);
  2544. var
  2545.   I: Integer;
  2546.   P3: PRGBTripleArray;
  2547.   P4: PRGBQuadArray;
  2548. begin
  2549.   P3 := PRGBTripleArray(@ColorTable);
  2550.   P4 := Pointer(P3);
  2551.   for I := 1 to ColorCount-1 do  // don't move zeroth item
  2552.     with P4^[I], P3^[I] do
  2553.     begin
  2554.       rgbtRed := rgbRed;
  2555.       rgbtGreen := rgbGreen;
  2556.       rgbtBlue := rgbBlue;
  2557.     end;
  2558.   if ColorCount < 256 then
  2559.   begin
  2560.     FillChar(P3^[ColorCount], (256 - ColorCount) * sizeof(TRGBTriple), 0);
  2561.     ColorCount := 256;   // OS2 color tables always have 256 entries
  2562.   end;
  2563. end;
  2564.  
  2565. procedure ByteSwapColors(var Colors; Count: Integer);
  2566. var   // convert RGB to BGR and vice-versa.  TRGBQuad <-> TPaletteEntry
  2567.   SysInfo: TSystemInfo;
  2568. begin
  2569.   GetSystemInfo(SysInfo);
  2570.   asm
  2571.         MOV   EDX, Colors
  2572.         MOV   ECX, Count
  2573.         DEC   ECX
  2574.         JS    @@END
  2575.         LEA   EAX, SysInfo
  2576.         CMP   [EAX].TSystemInfo.wProcessorLevel, 3
  2577.         JE    @@386
  2578.   @@1:  MOV   EAX, [EDX+ECX*4]
  2579.         BSWAP EAX
  2580.         SHR   EAX,8
  2581.         MOV   [EDX+ECX*4],EAX
  2582.         DEC   ECX
  2583.         JNZ   @@1
  2584.         JMP   @@END
  2585.   @@386:
  2586.         PUSH  EBX
  2587.   @@2:  XOR   EBX,EBX
  2588.         MOV   EAX, [EDX+ECX*4]
  2589.         MOV   BH, AL
  2590.         MOV   BL, AH
  2591.         SHR   EAX,16
  2592.         SHL   EBX,8
  2593.         MOV   BL, AL
  2594.         MOV   [EDX+ECX*4],EBX
  2595.         DEC   ECX
  2596.         JNZ   @@2
  2597.         POP   EBX
  2598.     @@END:
  2599.   end;
  2600. end;
  2601.  
  2602. type
  2603.   TMaxLogPalette = packed record
  2604.     palVersion: Word;
  2605.     palNumEntries: Word;
  2606.     palPalEntry: array [Byte] of TPaletteEntry;
  2607.   end;
  2608.  
  2609. procedure SystemPaletteOverride(var Pal: TMaxLogPalette);
  2610. var
  2611.   DC: HDC;
  2612.   SysPalSize: Integer;
  2613. begin
  2614.   DC := GetDC(0);
  2615.   try
  2616.     SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
  2617.     if (Pal.palNumEntries = 16) and (SysPalSize >= 16) then
  2618.     begin
  2619.       { Ignore the disk image of the palette for 16 color bitmaps.
  2620.         Replace with the first and last 8 colors of the system palette }
  2621.       GetSystemPaletteEntries(DC, 0, 8, Pal.palPalEntry);
  2622.       GetSystemPaletteEntries(DC, SysPalSize - 8, 8, Pal.palPalEntry[8]);
  2623.     end
  2624.   finally
  2625.     ReleaseDC(0,DC);
  2626.   end;
  2627. end;
  2628.  
  2629. function PaletteFromDIBColorTable(DIBHandle: THandle; ColorTable: Pointer;
  2630.   ColorCount: Integer): HPalette;
  2631. var
  2632.   DC: HDC;
  2633.   Save: THandle;
  2634.   Pal: TMaxLogPalette;
  2635. begin
  2636.   Result := 0;
  2637.   Pal.palVersion := $300;
  2638.   if DIBHandle <> 0 then
  2639.   begin
  2640.     DC := CreateCompatibleDC(0);
  2641.     Save := SelectObject(DC, DIBHandle);
  2642.     Pal.palNumEntries := GetDIBColorTable(DC, 0, 255, Pal.palPalEntry);
  2643.     SelectObject(DC, Save);
  2644.     DeleteDC(DC);
  2645.   end
  2646.   else
  2647.   begin
  2648.     Pal.palNumEntries := ColorCount;
  2649.     Move(ColorTable^, Pal.palPalEntry, ColorCount * 4);
  2650.   end;
  2651.   if Pal.palNumEntries = 0 then Exit;
  2652.   ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
  2653.   if Pal.palNumEntries = 16 then
  2654.     SystemPaletteOverride(Pal);
  2655.   Result := CreatePalette(PLogPalette(@Pal)^);
  2656. end;
  2657.  
  2658. function PaletteToDIBColorTable(Pal: HPalette;
  2659.   var ColorTable: array of TRGBQuad): Integer;
  2660. begin
  2661.   Result := 0;
  2662.   if (Pal = 0) or
  2663.      (GetObject(Pal, sizeof(Result), @Result) = 0) or
  2664.      (Result = 0) then Exit;
  2665.   if Result > High(ColorTable) then Result := High(ColorTable);
  2666.   GetPaletteEntries(Pal, 0, Result, ColorTable);
  2667.   ByteSwapColors(ColorTable, Result);
  2668. end;
  2669.  
  2670. procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP);
  2671. type
  2672.   PLongArray = ^TLongArray;
  2673.   TLongArray = array[0..1] of Longint;
  2674. var
  2675.   Temp: HBITMAP;
  2676.   NumColors: Integer;
  2677.   DC: HDC;
  2678.   Bits: Pointer;
  2679.   Colors: PLongArray;
  2680.   IconSize: TPoint;
  2681. begin
  2682.   IconSize.X := GetSystemMetrics(SM_CXICON);
  2683.   IconSize.Y := GetSystemMetrics(SM_CYICON);
  2684.   with BI do
  2685.   begin
  2686.     biHeight := biHeight shr 1; { Size in record is doubled }
  2687.     biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
  2688.     NumColors := GetDInColors(biBitCount);
  2689.   end;
  2690.   DC := GetDC(0);
  2691.   if DC = 0 then OutOfResources;
  2692.   try
  2693.     Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
  2694.     Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
  2695.     try
  2696.       XorBits := DupBits(Temp, IconSize, False);
  2697.     finally
  2698.       DeleteObject(Temp);
  2699.     end;
  2700.     with BI do
  2701.     begin
  2702.       Inc(Longint(Bits), biSizeImage);
  2703.       biBitCount := 1;
  2704.       biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
  2705.       biClrUsed := 2;
  2706.       biClrImportant := 2;
  2707.     end;
  2708.     Colors := Pointer(Longint(@BI) + SizeOf(BI));
  2709.     Colors^[0] := 0;
  2710.     Colors^[1] := $FFFFFF;
  2711.     Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
  2712.     try
  2713.       AndBits := DupBits(Temp, IconSize, True);
  2714.     finally
  2715.       DeleteObject(Temp);
  2716.     end;
  2717.   finally
  2718.     ReleaseDC(0, DC);
  2719.   end;
  2720. end;
  2721.  
  2722. procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
  2723.   StartOffset: Integer);
  2724. type
  2725.   PIconRecArray = ^TIconRecArray;
  2726.   TIconRecArray = array[0..300] of TIconRec;
  2727. var
  2728.   List: PIconRecArray;
  2729.   HeaderLen, Length: Integer;
  2730.   Colors, BitsPerPixel: Word;
  2731.   C1, C2, N, Index: Integer;
  2732.   IconSize: TPoint;
  2733.   DC: HDC;
  2734.   BI: PBitmapInfoHeader;
  2735.   ResData: Pointer;
  2736.   XorBits, AndBits: HBITMAP;
  2737.   XorInfo, AndInfo: Windows.TBitmap;
  2738.   XorMem, AndMem: Pointer;
  2739.   XorLen, AndLen: Integer;
  2740. {
  2741. var
  2742.   P: PChar;
  2743. begin
  2744.   P := Pointer(Integer((Stream as TCustomMemoryStream).Memory) + Stream.Position);
  2745. //  N := LookupIconIdFromDirectoryEx(Pointer(P), True, 0, 0, LR_DEFAULTCOLOR);
  2746.   Icon := GDICheck(CreateIconFromResourceEx(
  2747.     Pointer(P + PIconRec(P)^.DIBOffset - StartOffset),
  2748.     PIconRec(P)^.DIBSize, True, $00030000, 0, 0, LR_DEFAULTCOLOR));
  2749. }
  2750. begin
  2751.   HeaderLen := SizeOf(TIconRec) * ImageCount;
  2752.   List := AllocMem(HeaderLen);
  2753.   try
  2754.     Stream.Read(List^, HeaderLen);
  2755.     IconSize.X := GetSystemMetrics(SM_CXICON);
  2756.     IconSize.Y := GetSystemMetrics(SM_CYICON);
  2757.     DC := GetDC(0);
  2758.     if DC = 0 then OutOfResources;
  2759.     try
  2760.       BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
  2761.       if BitsPerPixel = 24 then
  2762.         Colors := 0
  2763.       else
  2764.         Colors := 1 shl BitsPerPixel;
  2765.     finally
  2766.       ReleaseDC(0, DC);
  2767.     end;
  2768.     Index := -1;
  2769.  
  2770.     { the following code determines which image most closely matches the
  2771.       current device. It is not meant to absolutely match Windows
  2772.       (known broken) algorithm }
  2773.     C2 := 0;
  2774.     for N := 0 to ImageCount - 1 do
  2775.     begin
  2776.       C1 := List^[N].Colors;
  2777.       if C1 = Colors then
  2778.       begin
  2779.         Index := N;
  2780.         Break;
  2781.       end
  2782.       else if Index = -1 then
  2783.       begin
  2784.         if C1 <= Colors then
  2785.         begin
  2786.           Index := N;
  2787.           C2 := List^[N].Colors;
  2788.         end;
  2789.       end
  2790.       else
  2791.         if C1 > C2 then
  2792.           Index := N;
  2793.     end;
  2794.     if Index = -1 then Index := 0;
  2795.     with List^[Index] do
  2796.     begin
  2797.       BI := AllocMem(DIBSize);
  2798.       try
  2799.         Stream.Seek(DIBOffset  - (HeaderLen + StartOffset), 1);
  2800.         Stream.Read(BI^, DIBSize);
  2801.         TwoBitsFromDIB(BI^, XorBits, AndBits);
  2802.         GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
  2803.         GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
  2804.         with AndInfo do
  2805.           AndLen := bmWidthBytes * bmHeight * bmPlanes;
  2806.         with XorInfo do
  2807.           XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
  2808.         Length := AndLen + XorLen;
  2809.         ResData := AllocMem(Length);
  2810.         try
  2811.           AndMem := ResData;
  2812.           with AndInfo do
  2813.             XorMem := Pointer(Longint(ResData) + AndLen);
  2814.           GetBitmapBits(AndBits, AndLen, AndMem);
  2815.           GetBitmapBits(XorBits, XorLen, XorMem);
  2816.           DeleteObject(XorBits);
  2817.           DeleteObject(AndBits);
  2818.           Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
  2819.             XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
  2820.           if Icon = 0 then GDIError;
  2821.         finally
  2822.           FreeMem(ResData, Length);
  2823.         end;
  2824.       finally
  2825.         FreeMem(BI, DIBSize);
  2826.       end;
  2827.     end;
  2828.   finally
  2829.     FreeMem(List, HeaderLen);
  2830.   end;
  2831. end;
  2832.  
  2833. function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
  2834. type
  2835.   PWord = ^Word;
  2836. var
  2837.   pW: PWord;
  2838.   pEnd: PWord;
  2839. begin
  2840.   Result := 0;
  2841.   pW := @WMF;
  2842.   pEnd := @WMF.CheckSum;
  2843.   while Longint(pW) < Longint(pEnd) do
  2844.   begin
  2845.     Result := Result xor pW^;
  2846.     Inc(Longint(pW), SizeOf(Word));
  2847.   end;
  2848. end;
  2849.  
  2850. procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  2851.   Colors: Integer);
  2852. var
  2853.   DS: TDIBSection;
  2854.   Bytes: Integer;
  2855. begin
  2856.   DS.dsbmih.biSize := 0;
  2857.   Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
  2858.   if Bytes = 0 then InvalidBitmap
  2859.   else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
  2860.     (DS.dsbmih.biSize >= sizeof(DS.dsbmih)) then
  2861.     BI := DS.dsbmih
  2862.   else
  2863.   begin
  2864.     FillChar(BI, sizeof(BI), 0);
  2865.     with BI, DS.dsbm do
  2866.     begin
  2867.       biSize := SizeOf(BI);
  2868.       biWidth := bmWidth;
  2869.       biHeight := bmHeight;
  2870.     end;
  2871.   end;
  2872.   if Colors <> 0 then
  2873.     case Colors of
  2874.       2: BI.biBitCount := 1;
  2875.       16: BI.biBitCount := 4;
  2876.       256: BI.biBitCount := 8;
  2877.     end
  2878.   else BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
  2879.   BI.biPlanes := 1;
  2880.   if BI.biSizeImage = 0 then
  2881.     BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
  2882. end;
  2883.  
  2884. procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  2885.   var ImageSize: DWORD; Colors: Integer);
  2886. var
  2887.   BI: TBitmapInfoHeader;
  2888. begin
  2889.   InitializeBitmapInfoHeader(Bitmap, BI, Colors);
  2890.   if BI.biBitCount > 8 then
  2891.   begin
  2892.     InfoHeaderSize := SizeOf(TBitmapInfoHeader);
  2893.     if (BI.biCompression and BI_BITFIELDS) <> 0 then
  2894.       Inc(InfoHeaderSize, 12);
  2895.   end
  2896.   else
  2897.     InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) *
  2898.       (1 shl BI.biBitCount);
  2899.   ImageSize := BI.biSizeImage;
  2900. end;
  2901.  
  2902. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  2903.   var ImageSize: DWORD);
  2904. begin
  2905.   InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
  2906. end;
  2907.  
  2908. function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  2909.   var BitmapInfo; var Bits; Colors: Integer): Boolean;
  2910. var
  2911.   OldPal: HPALETTE;
  2912.   DC: HDC;
  2913. begin
  2914.   InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
  2915.   OldPal := 0;
  2916.   DC := CreateCompatibleDC(0);
  2917.   try
  2918.     if Palette <> 0 then
  2919.     begin
  2920.       OldPal := SelectPalette(DC, Palette, False);
  2921.       RealizePalette(DC);
  2922.     end;
  2923.     Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
  2924.       TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
  2925.   finally
  2926.     if OldPal <> 0 then SelectPalette(DC, OldPal, False);
  2927.     DeleteDC(DC);
  2928.   end;
  2929. end;
  2930.  
  2931. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  2932. begin
  2933.   Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
  2934. end;
  2935.  
  2936. procedure WinError;
  2937. begin
  2938. end;
  2939.  
  2940. procedure CheckBool(Result: Bool);
  2941. begin
  2942.   if not Result then WinError;
  2943. end;
  2944.  
  2945. procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean);
  2946. var
  2947.   IconInfo: TIconInfo;
  2948.   MonoInfoSize, ColorInfoSize: Integer;
  2949.   MonoBitsSize, ColorBitsSize: DWORD;
  2950.   MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
  2951.   CI: TCursorOrIcon;
  2952.   List: TIconRec;
  2953.   Length: Longint;
  2954. begin
  2955.   FillChar(CI, SizeOf(CI), 0);
  2956.   FillChar(List, SizeOf(List), 0);
  2957.   CheckBool(GetIconInfo(Icon, IconInfo));
  2958.   try
  2959.     InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 2);
  2960.     InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 16);
  2961.     MonoInfo := nil;
  2962.     MonoBits := nil;
  2963.     ColorInfo := nil;
  2964.     ColorBits := nil;
  2965.     try
  2966.       MonoInfo := AllocMem(MonoInfoSize);
  2967.       MonoBits := AllocMem(MonoBitsSize);
  2968.       ColorInfo := AllocMem(ColorInfoSize);
  2969.       ColorBits := AllocMem(ColorBitsSize);
  2970.       InternalGetDIB(IconInfo.hbmMask, 0, MonoInfo^, MonoBits^, 2);
  2971.       InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 16);
  2972.       if WriteLength then
  2973.       begin
  2974.         Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
  2975.           ColorBitsSize + MonoBitsSize;
  2976.         Stream.Write(Length, SizeOf(Length));
  2977.       end;
  2978.       with CI do
  2979.       begin
  2980.         CI.wType := RC3_ICON;
  2981.         CI.Count := 1;
  2982.       end;
  2983.       Stream.Write(CI, SizeOf(CI));
  2984.       with List, PBitmapInfoHeader(ColorInfo)^ do
  2985.       begin
  2986.         Width := biWidth;
  2987.         Height := biHeight;
  2988.         Colors := biPlanes * biBitCount;
  2989.         DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
  2990.         DIBOffset := SizeOf(CI) + SizeOf(List);
  2991.       end;
  2992.       Stream.Write(List, SizeOf(List));
  2993.       with PBitmapInfoHeader(ColorInfo)^ do
  2994.         Inc(biHeight, biHeight); { color height includes mono bits }
  2995.       Stream.Write(ColorInfo^, ColorInfoSize);
  2996.       Stream.Write(ColorBits^, ColorBitsSize);
  2997.       Stream.Write(MonoBits^, MonoBitsSize);
  2998.     finally
  2999.       FreeMem(ColorInfo, ColorInfoSize);
  3000.       FreeMem(ColorBits, ColorBitsSize);
  3001.       FreeMem(MonoInfo, MonoInfoSize);
  3002.       FreeMem(MonoBits, MonoBitsSize);
  3003.     end;
  3004.   finally
  3005.     DeleteObject(IconInfo.hbmColor);
  3006.     DeleteObject(IconInfo.hbmMask);
  3007.   end;
  3008. end;
  3009.  
  3010. { TGraphic }
  3011.  
  3012. constructor TGraphic.Create;
  3013. begin
  3014.   inherited Create;
  3015. end;
  3016.  
  3017. procedure TGraphic.Changed(Sender: TObject);
  3018. begin
  3019.   FModified := True;
  3020.   if Assigned(FOnChange) then FOnChange(Self);
  3021. end;
  3022.  
  3023. procedure TGraphic.DefineProperties(Filer: TFiler);
  3024.  
  3025.   function DoWrite: Boolean;
  3026.   begin
  3027.     if Filer.Ancestor <> nil then
  3028.       Result := not (Filer.Ancestor is TGraphic) or
  3029.         not Equals(TGraphic(Filer.Ancestor))
  3030.     else
  3031.       Result := not Empty;
  3032.   end;
  3033.  
  3034. begin
  3035.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3036. end;
  3037.  
  3038. function TGraphic.Equals(Graphic: TGraphic): Boolean;
  3039. var
  3040.   MyImage, GraphicsImage: TMemoryStream;
  3041. begin
  3042.   Result := (Graphic <> nil) and (ClassType = Graphic.ClassType);
  3043.   if Empty or Graphic.Empty then
  3044.   begin
  3045.     Result := Empty and Graphic.Empty;
  3046.     Exit;
  3047.   end;
  3048.   if Result then
  3049.   begin
  3050.     MyImage := TMemoryStream.Create;
  3051.     try
  3052.       WriteData(MyImage);
  3053.       GraphicsImage := TMemoryStream.Create;
  3054.       try
  3055.         Graphic.WriteData(GraphicsImage);
  3056.         Result := (MyImage.Size = GraphicsImage.Size) and
  3057.           CompareMem(MyImage.Memory, GraphicsImage.Memory, MyImage.Size);
  3058.       finally
  3059.         GraphicsImage.Free;
  3060.       end;
  3061.     finally
  3062.       MyImage.Free;
  3063.     end;
  3064.   end;
  3065. end;
  3066.  
  3067. function TGraphic.GetPalette: HPALETTE;
  3068. begin
  3069.   Result := 0;
  3070. end;
  3071.  
  3072. function TGraphic.GetTransparent: Boolean;
  3073. begin
  3074.   Result := FTransparent;
  3075. end;
  3076.  
  3077. procedure TGraphic.LoadFromFile(const Filename: string);
  3078. var
  3079.   Stream: TStream;
  3080. begin
  3081.   Stream := TFileStream.Create(Filename, fmOpenRead);
  3082.   try
  3083.     LoadFromStream(Stream);
  3084.   finally
  3085.     Stream.Free;
  3086.   end;
  3087. end;
  3088.  
  3089. procedure TGraphic.Progress(Sender: TObject; Stage: TProgressStage;
  3090.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  3091. begin
  3092.   if Assigned(FOnProgress) then
  3093.     FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  3094. end;
  3095.  
  3096. procedure TGraphic.ReadData(Stream: TStream);
  3097. begin
  3098.   LoadFromStream(Stream);
  3099. end;
  3100.  
  3101. procedure TGraphic.SaveToFile(const Filename: string);
  3102. var
  3103.   Stream: TStream;
  3104. begin
  3105.   Stream := TFileStream.Create(Filename, fmCreate);
  3106.   try
  3107.     SaveToStream(Stream);
  3108.   finally
  3109.     Stream.Free;
  3110.   end;
  3111. end;
  3112.  
  3113. procedure TGraphic.SetPalette(Value: HPalette);
  3114. begin
  3115. end;
  3116.  
  3117. procedure TGraphic.SetModified(Value: Boolean);
  3118. begin
  3119.   if Value then
  3120.     Changed(Self) else
  3121.     FModified := False;
  3122. end;
  3123.  
  3124. procedure TGraphic.SetTransparent(Value: Boolean);
  3125. begin
  3126.   if Value <> FTransparent then
  3127.   begin
  3128.     FTransparent := Value;
  3129.     Changed(Self);
  3130.   end;
  3131. end;
  3132.  
  3133. procedure TGraphic.WriteData(Stream: TStream);
  3134. begin
  3135.   SaveToStream(Stream);
  3136. end;
  3137.  
  3138. { TPicture }
  3139.  
  3140. type
  3141.   PFileFormat = ^TFileFormat;
  3142.   TFileFormat = record
  3143.     GraphicClass: TGraphicClass;
  3144.     Extension: string;
  3145.     Description: string;
  3146.     DescResID: Integer;
  3147.   end;
  3148.  
  3149.   TFileFormatsList = class(TList)
  3150.   public
  3151.     constructor Create;
  3152.     destructor Destroy; override;
  3153.     procedure Add(const Ext, Desc: String; DescID: Integer; AClass: TGraphicClass);
  3154.     function FindExt(const Ext: string): TGraphicClass;
  3155.     function FindClassName(const Classname: string): TGraphicClass;
  3156.     procedure Remove(AClass: TGraphicClass);
  3157.     procedure BuildFilterStrings(GraphicClass: TGraphicClass;
  3158.       var Descriptions, Filters: string);
  3159.   end;
  3160.  
  3161. constructor TFileFormatsList.Create;
  3162. begin
  3163.   inherited Create;
  3164.   Add('wmf', SVMetafiles, 0, TMetafile);
  3165.   Add('emf', SVEnhMetafiles, 0, TMetafile);
  3166.   Add('ico', SVIcons, 0, TIcon);
  3167.   Add('bmp', SVBitmaps, 0, TBitmap);
  3168. end;
  3169.  
  3170. destructor TFileFormatsList.Destroy;
  3171. var
  3172.   I: Integer;
  3173. begin
  3174.   for I := 0 to Count-1 do
  3175.     Dispose(PFileFormat(Items[I]));
  3176.   inherited Destroy;
  3177. end;
  3178.  
  3179. procedure TFileFormatsList.Add(const Ext, Desc: String; DescID: Integer;
  3180.   AClass: TGraphicClass);
  3181. var
  3182.   NewRec: PFileFormat;
  3183. begin
  3184.   New(NewRec);
  3185.   with NewRec^ do
  3186.   begin
  3187.     Extension := LowerCase(Ext);
  3188.     GraphicClass := AClass;
  3189.     Description := Desc;
  3190.     DescResID := DescID;
  3191.   end;
  3192.   inherited Add(NewRec);
  3193. end;
  3194.  
  3195. function TFileFormatsList.FindExt(const Ext: string): TGraphicClass;
  3196. var
  3197.   I: Integer;
  3198. begin
  3199.   for I := Count-1 downto 0 do
  3200.     with PFileFormat(Items[I])^ do
  3201.       if Extension = Ext then
  3202.       begin
  3203.         Result := GraphicClass;
  3204.         Exit;
  3205.       end;
  3206.   Result := nil;
  3207. end;
  3208.  
  3209. function TFileFormatsList.FindClassName(const ClassName: string): TGraphicClass;
  3210. var
  3211.   I: Integer;
  3212. begin
  3213.   for I := Count-1 downto 0 do
  3214.   begin
  3215.     Result := PFileFormat(Items[I])^.GraphicClass;
  3216.     if Result.ClassName = Classname then Exit;
  3217.   end;
  3218.   Result := nil;
  3219. end;
  3220.  
  3221. procedure TFileFormatsList.Remove(AClass: TGraphicClass);
  3222. var
  3223.   I: Integer;
  3224.   P: PFileFormat;
  3225. begin
  3226.   for I := Count-1 downto 0 do
  3227.   begin
  3228.     P := PFileFormat(Items[I]);
  3229.     if P^.GraphicClass.InheritsFrom(AClass) then
  3230.     begin
  3231.       Dispose(P);
  3232.       Delete(I);
  3233.     end;
  3234.   end;
  3235. end;
  3236.  
  3237. procedure TFileFormatsList.BuildFilterStrings(GraphicClass: TGraphicClass;
  3238.   var Descriptions, Filters: string);
  3239. var
  3240.   C, I: Integer;
  3241.   P: PFileFormat;
  3242. begin
  3243.   Descriptions := '';
  3244.   Filters := '';
  3245.   C := 0;
  3246.   for I := Count-1 downto 0 do
  3247.   begin
  3248.     P := PFileFormat(Items[I]);
  3249.     if P^.GraphicClass.InheritsFrom(GraphicClass) then
  3250.       with P^ do
  3251.       begin
  3252.         if C <> 0 then
  3253.         begin
  3254.           Descriptions := Descriptions + '|';
  3255.           Filters := Filters + ';';
  3256.         end;
  3257.         if (Description = '') and (DescResID <> 0) then
  3258.           Description := LoadStr(DescResID);
  3259.         FmtStr(Descriptions, '%s%s (*.%s)|*.%2:s', [Descriptions, Description, Extension]);
  3260.         FmtStr(Filters, '%s*.%s', [Filters, Extension]);
  3261.         Inc(C);
  3262.       end;
  3263.   end;
  3264.   if C > 1 then
  3265.     FmtStr(Descriptions, '%s (%s)|%1:s|%s', [sAllFilter, Filters, Descriptions]);
  3266. end;
  3267.  
  3268. type
  3269.   TClipboardFormats = class
  3270.   private
  3271.     FClasses: TList;
  3272.     FFormats: TList;
  3273.   public
  3274.     constructor Create;
  3275.     destructor Destroy; override;
  3276.     procedure Add(Fmt: Word; AClass: TGraphicClass);
  3277.     function FindFormat(Fmt: Word): TGraphicClass;
  3278.     procedure Remove(AClass: TGraphicClass);
  3279.   end;
  3280.  
  3281. constructor TClipboardFormats.Create;
  3282. begin
  3283.   FClasses := TList.Create;
  3284.   FFormats := TList.Create;
  3285.   Add(CF_METAFILEPICT, TMetafile);
  3286.   Add(CF_ENHMETAFILE, TMetafile);
  3287.   Add(CF_BITMAP, TBitmap);
  3288. end;
  3289.  
  3290. destructor TClipboardFormats.Destroy;
  3291. begin
  3292.   FClasses.Free;
  3293.   FFormats.Free;
  3294. end;
  3295.  
  3296. procedure TClipboardFormats.Add(Fmt: Word; AClass: TGraphicClass);
  3297. var
  3298.   I: Integer;
  3299. begin
  3300.   I := FClasses.Add(AClass);
  3301.   try
  3302.     FFormats.Add(Pointer(Integer(Fmt)));
  3303.   except
  3304.     FClasses.Delete(I);
  3305.     raise;
  3306.   end;
  3307. end;
  3308.  
  3309. function TClipboardFormats.FindFormat(Fmt: Word): TGraphicClass;
  3310. var
  3311.   I: Integer;
  3312. begin
  3313.   for I := FFormats.Count-1 downto 0 do
  3314.     if Word(FFormats[I]) = Fmt then
  3315.     begin
  3316.       Result := FClasses[I];
  3317.       Exit;
  3318.     end;
  3319.   Result := nil;
  3320. end;
  3321.  
  3322. procedure TClipboardFormats.Remove(AClass: TGraphicClass);
  3323. var
  3324.   I: Integer;
  3325. begin
  3326.   for I := FClasses.Count-1 downto 0 do
  3327.     if TGraphicClass(FClasses[I]).InheritsFrom(AClass) then
  3328.     begin
  3329.       FClasses.Delete(I);
  3330.       FFormats.Delete(I);
  3331.     end;
  3332. end;
  3333.  
  3334. var
  3335.   ClipboardFormats: TClipboardFormats = nil;
  3336.   FileFormats: TFileFormatsList = nil;
  3337.  
  3338. function GetFileFormats: TFileFormatsList;
  3339. begin
  3340.   if FileFormats = nil then FileFormats := TFileFormatsList.Create;
  3341.   Result := FileFormats;
  3342. end;
  3343.  
  3344. function GetClipboardFormats: TClipboardFormats;
  3345. begin
  3346.   if ClipboardFormats = nil then ClipboardFormats := TClipboardFormats.Create;
  3347.   Result := ClipboardFormats;
  3348. end;
  3349.  
  3350. constructor TPicture.Create;
  3351. begin
  3352.   inherited Create;
  3353.   GetFileFormats;
  3354.   GetClipboardFormats;
  3355. end;
  3356.  
  3357. destructor TPicture.Destroy;
  3358. begin
  3359.   FGraphic.Free;
  3360.   inherited Destroy;
  3361. end;
  3362.  
  3363. procedure TPicture.AssignTo(Dest: TPersistent);
  3364. begin
  3365.   if Graphic is Dest.ClassType then
  3366.     Dest.Assign(Graphic)
  3367.   else
  3368.     inherited AssignTo(Dest);
  3369. end;
  3370.  
  3371. procedure TPicture.ForceType(GraphicType: TGraphicClass);
  3372. begin
  3373.   if not (Graphic is GraphicType) then
  3374.   begin
  3375.     FGraphic.Free;
  3376.     FGraphic := nil;
  3377.     FGraphic := GraphicType.Create;
  3378.     FGraphic.OnChange := Changed;
  3379.     FGraphic.OnProgress := Progress;
  3380.     Changed(Self);
  3381.   end;
  3382. end;
  3383.  
  3384. function TPicture.GetBitmap: TBitmap;
  3385. begin
  3386.   ForceType(TBitmap);
  3387.   Result := TBitmap(Graphic);
  3388. end;
  3389.  
  3390. function TPicture.GetIcon: TIcon;
  3391. begin
  3392.   ForceType(TIcon);
  3393.   Result := TIcon(Graphic);
  3394. end;
  3395.  
  3396. function TPicture.GetMetafile: TMetafile;
  3397. begin
  3398.   ForceType(TMetafile);
  3399.   Result := TMetafile(Graphic);
  3400. end;
  3401.  
  3402. procedure TPicture.SetBitmap(Value: TBitmap);
  3403. begin
  3404.   SetGraphic(Value);
  3405. end;
  3406.  
  3407. procedure TPicture.SetIcon(Value: TIcon);
  3408. begin
  3409.   SetGraphic(Value);
  3410. end;
  3411.  
  3412. procedure TPicture.SetMetafile(Value: TMetafile);
  3413. begin
  3414.   SetGraphic(Value);
  3415. end;
  3416.  
  3417. procedure TPicture.SetGraphic(Value: TGraphic);
  3418. var
  3419.   NewGraphic: TGraphic;
  3420. begin
  3421.   NewGraphic := nil;
  3422.   if Value <> nil then
  3423.   begin
  3424.     NewGraphic := TGraphicClass(Value.ClassType).Create;
  3425.     NewGraphic.Assign(Value);
  3426.     NewGraphic.OnChange := Changed;
  3427.     NewGraphic.OnProgress := Progress;
  3428.   end;
  3429.   try
  3430.     FGraphic.Free;
  3431.     FGraphic := NewGraphic;
  3432.     Changed(Self);
  3433.   except
  3434.     NewGraphic.Free;
  3435.     raise;
  3436.   end;
  3437. end;
  3438.  
  3439. { Based on the extension of Filename, create the cooresponding TGraphic class
  3440.   and call its LoadFromFile method. }
  3441.  
  3442. procedure TPicture.LoadFromFile(const Filename: string);
  3443. var
  3444.   Ext: string;
  3445.   NewGraphic: TGraphic;
  3446.   GraphicClass: TGraphicClass;
  3447. begin
  3448.   Ext := AnsiLowerCase(ExtractFileExt(Filename));
  3449.   Delete(Ext, 1, 1);
  3450.   GraphicClass := FileFormats.FindExt(Ext);
  3451.   if GraphicClass = nil then
  3452.     raise EInvalidGraphic.CreateFmt(SUnknownExtension, [Ext]);
  3453.  
  3454.   NewGraphic := GraphicClass.Create;
  3455.   try
  3456.     NewGraphic.OnProgress := Progress;
  3457.     NewGraphic.LoadFromFile(Filename);
  3458.   except
  3459.     NewGraphic.Free;
  3460.     raise;
  3461.   end;
  3462.   FGraphic.Free;
  3463.   FGraphic := NewGraphic;
  3464.   FGraphic.OnChange := Changed;
  3465.   Changed(Self);
  3466. end;
  3467.  
  3468. procedure TPicture.SaveToFile(const Filename: string);
  3469. begin
  3470.   if FGraphic <> nil then FGraphic.SaveToFile(Filename);
  3471. end;
  3472.  
  3473. procedure TPicture.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  3474.   APalette: HPALETTE);
  3475. var
  3476.   NewGraphic: TGraphic;
  3477.   GraphicClass: TGraphicClass;
  3478. begin
  3479.   GraphicClass := ClipboardFormats.FindFormat(AFormat);
  3480.   if GraphicClass = nil then
  3481.     InvalidGraphic(SUnknownClipboardFormat);
  3482.  
  3483.   NewGraphic := GraphicClass.Create;
  3484.   try
  3485.     NewGraphic.OnProgress := Progress;
  3486.     NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
  3487.   except
  3488.     NewGraphic.Free;
  3489.     raise;
  3490.   end;
  3491.   FGraphic.Free;
  3492.   FGraphic := NewGraphic;
  3493.   FGraphic.OnChange := Changed;
  3494.   Changed(Self);
  3495. end;
  3496.  
  3497. procedure TPicture.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  3498.   var APalette: HPALETTE);
  3499. begin
  3500.   if FGraphic <> nil then
  3501.     FGraphic.SaveToClipboardFormat(AFormat, AData, APalette);
  3502. end;
  3503.  
  3504. class function TPicture.SupportsClipboardFormat(AFormat: Word): Boolean;
  3505. begin
  3506.   Result := GetClipboardFormats.FindFormat(AFormat) <> nil;
  3507. end;
  3508.  
  3509. procedure TPicture.Assign(Source: TPersistent);
  3510. begin
  3511.   if Source = nil then
  3512.     SetGraphic(nil)
  3513.   else if Source is TPicture then
  3514.     SetGraphic(TPicture(Source).Graphic)
  3515.   else if Source is TGraphic then
  3516.     SetGraphic(TGraphic(Source))
  3517.   else
  3518.     inherited Assign(Source);
  3519. end;
  3520.  
  3521. class procedure TPicture.RegisterFileFormat(const AExtension,
  3522.   ADescription: string; AGraphicClass: TGraphicClass);
  3523. begin
  3524.   GetFileFormats.Add(AExtension, ADescription, 0, AGraphicClass);
  3525. end;
  3526.  
  3527. class procedure TPicture.RegisterFileFormatRes(const AExtension: String;
  3528.   ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  3529. begin
  3530.   GetFileFormats.Add(AExtension, '', ADescriptionResID, AGraphicClass);
  3531. end;
  3532.  
  3533. class procedure TPicture.RegisterClipboardFormat(AFormat: Word;
  3534.   AGraphicClass: TGraphicClass);
  3535. begin
  3536.   GetClipboardFormats.Add(AFormat, AGraphicClass);
  3537. end;
  3538.  
  3539. class procedure TPicture.UnRegisterGraphicClass(AClass: TGraphicClass);
  3540. begin
  3541.   if FileFormats <> nil then FileFormats.Remove(AClass);
  3542.   if ClipboardFormats <> nil then ClipboardFormats.Remove(AClass);
  3543. end;
  3544.  
  3545. procedure TPicture.Changed(Sender: TObject);
  3546. begin
  3547.   if Assigned(FOnChange) then FOnChange(Self);
  3548.   if FNotify <> nil then FNotify.Changed;
  3549. end;
  3550.  
  3551. procedure TPicture.Progress(Sender: TObject; Stage: TProgressStage;
  3552.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  3553. begin
  3554.   if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  3555. end;
  3556.  
  3557.  
  3558. procedure TPicture.ReadData(Stream: TStream);
  3559. var
  3560.   CName: string[63];
  3561.   NewGraphic: TGraphic;
  3562.   GraphicClass: TGraphicClass;
  3563. begin
  3564.   Stream.Read(CName[0], 1);
  3565.   Stream.Read(CName[1], Integer(CName[0]));
  3566.   GraphicClass := FileFormats.FindClassname(CName);
  3567.   if GraphicClass <> nil then
  3568.   begin
  3569.     NewGraphic := GraphicClass.Create;
  3570.     try
  3571.       NewGraphic.ReadData(Stream);
  3572.     except
  3573.       NewGraphic.Free;
  3574.       raise;
  3575.     end;
  3576.     FGraphic.Free;
  3577.     FGraphic := NewGraphic;
  3578.     FGraphic.OnChange := Changed;
  3579.     FGraphic.OnProgress := Progress;
  3580.     Changed(Self);
  3581.   end;
  3582. end;
  3583.  
  3584. procedure TPicture.WriteData(Stream: TStream);
  3585. var
  3586.   CName: string[63];
  3587. begin
  3588.   with Stream do
  3589.   begin
  3590.     CName := Graphic.ClassName;
  3591.     Write(CName, Length(CName) + 1);
  3592.     Graphic.WriteData(Stream);
  3593.   end;
  3594. end;
  3595.  
  3596. procedure TPicture.DefineProperties(Filer: TFiler);
  3597.  
  3598.   function DoWrite: Boolean;
  3599.   var
  3600.     Ancestor: TPicture;
  3601.   begin
  3602.     if Filer.Ancestor <> nil then
  3603.     begin
  3604.       Result := True;
  3605.       if Filer.Ancestor is TPicture then
  3606.       begin
  3607.         Ancestor := TPicture(Filer.Ancestor);
  3608.         Result := not ((Graphic = Ancestor.Graphic) or
  3609.           ((Graphic <> nil) and (Ancestor.Graphic <> nil) and
  3610.           Graphic.Equals(Ancestor.Graphic)));
  3611.       end;
  3612.     end
  3613.     else Result := Graphic <> nil;
  3614.   end;
  3615.  
  3616. begin
  3617.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3618. end;
  3619.  
  3620. function TPicture.GetWidth: Integer;
  3621. begin
  3622.   Result := 0;
  3623.   if FGraphic <> nil then Result := FGraphic.Width;
  3624. end;
  3625.  
  3626. function TPicture.GetHeight: Integer;
  3627. begin
  3628.   Result := 0;
  3629.   if FGraphic <> nil then Result := FGraphic.Height;
  3630. end;
  3631.  
  3632. { TMetafileImage }
  3633.  
  3634. destructor TMetafileImage.Destroy;
  3635. begin
  3636.   if FHandle <> 0 then DeleteEnhMetafile(FHandle);
  3637.   InternalDeletePalette(FPalette);
  3638.   inherited Destroy;
  3639. end;
  3640.  
  3641. procedure TMetafileImage.FreeHandle;
  3642. begin
  3643. end;
  3644.  
  3645.  
  3646. { TMetafileCanvas }
  3647.  
  3648. constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  3649. begin
  3650.   CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy,
  3651.     AMetafile.Description);
  3652. end;
  3653.  
  3654. constructor TMetafileCanvas.CreateWithComment(AMetafile : TMetafile;
  3655.   ReferenceDevice: HDC; const CreatedBy, Description: String);
  3656. var
  3657.   RefDC: HDC;
  3658.   R: TRect;
  3659.   Temp: HDC;
  3660.   P: PChar;
  3661. begin
  3662.   inherited Create;
  3663.   FMetafile := AMetafile;
  3664.   RefDC := ReferenceDevice;
  3665.   if ReferenceDevice = 0 then RefDC := GetDC(0);
  3666.   try
  3667.     if FMetafile.MMWidth = 0 then
  3668.       if FMetafile.Width = 0 then
  3669.         FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE)*100
  3670.       else
  3671.         FMetafile.MMWidth := MulDiv(FMetafile.Width,
  3672.           GetDeviceCaps(RefDC, HORZSIZE)*100, GetDeviceCaps(RefDC, HORZRES));
  3673.     if FMetafile.MMHeight = 0 then
  3674.       if FMetafile.Height = 0 then
  3675.         FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE)*100
  3676.       else
  3677.         FMetafile.MMHeight := MulDiv(FMetafile.Height,
  3678.           GetDeviceCaps(RefDC, VERTSIZE)*100, GetDeviceCaps(RefDC, VERTRES));
  3679.     R := Rect(0,0,FMetafile.MMWidth,FMetafile.MMHeight);
  3680.     if (Length(CreatedBy) > 0) or (Length(Description) > 0) then
  3681.       P := PChar(CreatedBy+#0+Description+#0#0)
  3682.     else
  3683.       P := nil;
  3684.     Temp := CreateEnhMetafile(RefDC, nil, @R, P);
  3685.     if Temp = 0 then GDIError;
  3686.     Handle := Temp;
  3687.   finally
  3688.     if ReferenceDevice = 0 then ReleaseDC(0, RefDC);
  3689.   end;
  3690. end;
  3691.  
  3692. destructor TMetafileCanvas.Destroy;
  3693. var
  3694.   Temp: HDC;
  3695. begin
  3696.   Temp := Handle;
  3697.   Handle := 0;
  3698.   FMetafile.Handle := CloseEnhMetafile(Temp);
  3699.   inherited Destroy;
  3700. end;
  3701.  
  3702. { TMetafile }
  3703.  
  3704. constructor TMetafile.Create;
  3705. begin
  3706.   inherited Create;
  3707.   FEnhanced := True;
  3708.   Transparent := True;
  3709.   Assign(nil);
  3710. end;
  3711.  
  3712. destructor TMetafile.Destroy;
  3713. begin
  3714.   FImage.Release;
  3715.   inherited Destroy;
  3716. end;
  3717.  
  3718. procedure TMetafile.Assign(Source: TPersistent);
  3719. var
  3720.   Pal: HPalette;
  3721. begin
  3722.   if (Source = nil) or (Source is TMetafile) then
  3723.   begin
  3724.     Pal := 0;
  3725.     if FImage <> nil then
  3726.     begin
  3727.       Pal := FImage.FPalette;
  3728.       FImage.Release;
  3729.     end;
  3730.     if Assigned(Source) then
  3731.     begin
  3732.       FImage := TMetafile(Source).FImage;
  3733.       FEnhanced := TMetafile(Source).Enhanced;
  3734.     end
  3735.     else
  3736.     begin
  3737.       FImage := TMetafileImage.Create;
  3738.       FEnhanced := True;
  3739.     end;
  3740.     FImage.Reference;
  3741.     PaletteModified := (Pal <> Palette) and (Palette <> 0);
  3742.     Changed(Self);
  3743.   end
  3744.   else
  3745.     inherited Assign(Source);
  3746. end;
  3747.  
  3748. procedure TMetafile.Clear;
  3749. begin
  3750.   NewImage;
  3751. end;
  3752.  
  3753. procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
  3754. var
  3755.   MetaPal, OldPal: HPALETTE;
  3756.   R: TRect;
  3757. begin
  3758.   if FImage = nil then Exit;
  3759.   MetaPal := Palette;
  3760.   OldPal := 0;
  3761.   if MetaPal <> 0 then
  3762.   begin
  3763.     OldPal := SelectPalette(ACanvas.Handle, MetaPal, True);
  3764.     RealizePalette(ACanvas.Handle);
  3765.   end;
  3766.   R := Rect;
  3767.   Dec(R.Right);  // Metafile rect includes right and bottom coords
  3768.   Dec(R.Bottom);
  3769.   PlayEnhMetaFile(ACanvas.Handle, FImage.FHandle, R);
  3770.   if MetaPal <> 0 then
  3771.     SelectPalette(ACanvas.Handle, OldPal, True);
  3772. end;
  3773.  
  3774. function TMetafile.GetAuthor: String;
  3775. var
  3776.   Temp: Integer;
  3777. begin
  3778.   Result := '';
  3779.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3780.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  3781.   if Temp <= 0 then Exit;
  3782.   SetLength(Result, Temp);
  3783.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  3784.   SetLength(Result, StrLen(PChar(Result)));
  3785. end;
  3786.  
  3787. function TMetafile.GetDesc: String;
  3788. var
  3789.   Temp: Integer;
  3790. begin
  3791.   Result := '';
  3792.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3793.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  3794.   if Temp <= 0 then Exit;
  3795.   SetLength(Result, Temp);
  3796.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  3797.   Delete(Result, 1, StrLen(PChar(Result))+1);
  3798.   SetLength(Result, StrLen(PChar(Result)));
  3799. end;
  3800.  
  3801. function TMetafile.GetEmpty;
  3802. begin
  3803.   Result := FImage = nil;
  3804. end;
  3805.  
  3806. function TMetafile.GetHandle: HENHMETAFILE;
  3807. begin
  3808.   if Assigned(FImage) then
  3809.     Result := FImage.FHandle
  3810.   else
  3811.     Result := 0;
  3812. end;
  3813.  
  3814. function TMetafile.GetHeight: Integer;
  3815. var
  3816.   EMFHeader: TEnhMetaHeader;
  3817. begin
  3818.   if FImage = nil then NewImage;
  3819.   with FImage do
  3820.    if FInch = 0 then
  3821.      if FHandle = 0 then
  3822.        Result := FTempHeight
  3823.      else
  3824.      begin               { convert 0.01mm units to referenceDC device pixels }
  3825.        GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3826.        Result := MulDiv(FHeight,                     { metafile height in 0.01mm }
  3827.          EMFHeader.szlDevice.cy,                      { device height in pixels }
  3828.          EMFHeader.szlMillimeters.cy*100);            { device height in mm }
  3829.      end
  3830.    else          { for WMF files, convert to font dpi based device pixels }
  3831.      Result := MulDiv(FHeight, ScreenLogPixels, 25400);
  3832. end;
  3833.  
  3834. function TMetafile.GetInch: Word;
  3835. begin
  3836.   Result := 0;
  3837.   if FImage <> nil then Result := FImage.FInch;
  3838. end;
  3839.  
  3840. function TMetafile.GetMMHeight: Integer;
  3841. begin
  3842.   if FImage = nil then NewImage;
  3843.   Result := FImage.FHeight;
  3844. end;
  3845.  
  3846. function TMetafile.GetMMWidth: Integer;
  3847. begin
  3848.   if FImage = nil then NewImage;
  3849.   Result := FImage.FWidth;
  3850. end;
  3851.  
  3852. function TMetafile.GetPalette: HPALETTE;
  3853. var
  3854.   LogPal: TMaxLogPalette;
  3855.   Count: Integer;
  3856. begin
  3857.   Result := 0;
  3858.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3859.   if FImage.FPalette = 0 then
  3860.   begin
  3861.     Count := GetEnhMetaFilePaletteEntries(FImage.FHandle, 0, nil);
  3862.     if Count = 0 then Exit;
  3863.     InternalDeletePalette(FImage.FPalette);
  3864.     LogPal.palVersion := $300;
  3865.     LogPal.palNumEntries := Count;
  3866.     GetEnhMetaFilePaletteEntries(FImage.FHandle, Count, @LogPal.palPalEntry);
  3867.     FImage.FPalette := CreatePalette(PLogPalette(@LogPal)^);
  3868.   end;
  3869.   Result := FImage.FPalette;
  3870. end;
  3871.  
  3872. function TMetafile.GetWidth: Integer;
  3873. var
  3874.   EMFHeader: TEnhMetaHeader;
  3875. begin
  3876.   if FImage = nil then NewImage;
  3877.   with FImage do
  3878.     if FInch = 0 then
  3879.       if FHandle = 0 then
  3880.         Result := FTempWidth
  3881.       else
  3882.       begin     { convert 0.01mm units to referenceDC device pixels }
  3883.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3884.         Result := MulDiv(FWidth,                      { metafile width in 0.01mm }
  3885.           EMFHeader.szlDevice.cx,                      { device width in pixels }
  3886.           EMFHeader.szlMillimeters.cx*100);            { device width in 0.01mm }
  3887.       end
  3888.     else      { for WMF files, convert to font dpi based device pixels }
  3889.       Result := MulDiv(FWidth, ScreenLogPixels, 25400);
  3890. end;
  3891.  
  3892. procedure TMetafile.LoadFromStream(Stream: TStream);
  3893. begin
  3894.   if TestEMF(Stream) then
  3895.     ReadEMFStream(Stream)
  3896.   else
  3897.     ReadWMFStream(Stream, Stream.Size - Stream.Position);
  3898.   PaletteModified := Palette <> 0;
  3899.   Changed(Self);
  3900. end;
  3901.  
  3902. procedure TMetafile.NewImage;
  3903. begin
  3904.   FImage.Release;
  3905.   FImage := TMetafileImage.Create;
  3906.   FImage.Reference;
  3907. end;
  3908.  
  3909. procedure TMetafile.ReadData(Stream: TStream);
  3910. var
  3911.   Length: Longint;
  3912. begin
  3913.   Stream.Read(Length, SizeOf(Longint));
  3914.   if TestEMF(Stream) then
  3915.     ReadEMFStream(Stream)
  3916.   else
  3917.     ReadWMFStream(Stream, Length);
  3918.   PaletteModified := Palette <> 0;
  3919.   Changed(Self);
  3920. end;
  3921.  
  3922. procedure TMetafile.ReadEMFStream(Stream: TStream);
  3923. var
  3924.   EnhHeader: TEnhMetaheader;
  3925.   Buf: PChar;
  3926. begin
  3927.   NewImage;
  3928.   Stream.ReadBuffer(EnhHeader, Sizeof(EnhHeader));
  3929.   if EnhHeader.dSignature <> ENHMETA_SIGNATURE then InvalidMetafile;
  3930.   GetMem(Buf, EnhHeader.nBytes);
  3931.   with FImage do
  3932.   try
  3933.     Move(EnhHeader, Buf^, Sizeof(EnhHeader));
  3934.     Stream.ReadBuffer(PChar(Buf + Sizeof(EnhHeader))^,
  3935.       EnhHeader.nBytes - Sizeof(EnhHeader));
  3936.     FHandle := SetEnhMetafileBits(EnhHeader.nBytes, Buf);
  3937.     if FHandle = 0 then InvalidMetafile;
  3938.     FInch := 0;
  3939.     with EnhHeader.rclFrame do
  3940.     begin
  3941.       FWidth := Right - Left;    { in 0.01 mm units }
  3942.       FHeight := Bottom - Top;
  3943.     end;
  3944.     Enhanced := True;
  3945.   finally
  3946.     FreeMem(Buf, EnhHeader.nBytes);
  3947.   end;
  3948. end;
  3949.  
  3950. procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
  3951. var
  3952.   WMF: TMetafileHeader;
  3953.   BitMem: Pointer;
  3954.   MFP: TMetaFilePict;
  3955. begin
  3956.   NewImage;
  3957.   Stream.Read(WMF, SizeOf(WMF));
  3958.   if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
  3959.     InvalidMetafile;
  3960.   Dec(Length, SizeOf(WMF));
  3961.   GetMem(Bitmem, Length);
  3962.   with FImage do
  3963.   try
  3964.     Stream.Read(BitMem^, Length);
  3965.     FImage.FInch := WMF.Inch;
  3966.     if WMF.Inch = 0 then WMF.Inch := 96;
  3967.     FWidth := MulDiv(WMF.Box.Right - WMF.Box.Left,25400,WMF.Inch);
  3968.     FHeight := MulDiv(WMF.Box.Bottom - WMF.Box.Top,25400,WMF.Inch);
  3969.     with MFP do
  3970.     begin
  3971.       MM := MM_ANISOTROPIC;
  3972.       xExt := 0;
  3973.       yExt := 0;
  3974.       hmf := 0;
  3975.     end;
  3976.     FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
  3977.     if FHandle = 0 then InvalidMetafile;
  3978.     Enhanced := False;
  3979.   finally
  3980.     Freemem(BitMem, Length);
  3981.   end;
  3982. end;
  3983.  
  3984. procedure TMetafile.SaveToFile(const Filename: String);
  3985. var
  3986.   SaveEnh: Boolean;
  3987. begin
  3988.   SaveEnh := Enhanced;
  3989.   if AnsiLowerCaseFileName(ExtractFileExt(Filename)) = '.wmf' then
  3990.     Enhanced := False;              { For 16 bit compatibility }
  3991.   inherited SaveToFile(Filename);
  3992.   Enhanced := SaveEnh;
  3993. end;
  3994.  
  3995. procedure TMetafile.SaveToStream(Stream: TStream);
  3996. begin
  3997.   if FImage <> nil then
  3998.     if Enhanced then
  3999.       WriteEMFStream(Stream)
  4000.     else
  4001.       WriteWMFStream(Stream);
  4002. end;
  4003.  
  4004. procedure TMetafile.SetHandle(Value: HENHMETAFILE);
  4005. var
  4006.   EnhHeader: TEnhMetaHeader;
  4007. begin
  4008.   if (Value <> 0) and
  4009.     (GetEnhMetafileHeader(Value, sizeof(EnhHeader), @EnhHeader) = 0) then
  4010.     InvalidMetafile;
  4011.   UniqueImage;
  4012.   if FImage.FHandle <> 0 then DeleteEnhMetafile(FImage.FHandle);
  4013.   InternalDeletePalette(FImage.FPalette);
  4014.   FImage.FPalette := 0;
  4015.   FImage.FHandle := Value;
  4016.   FImage.FTempWidth := 0;
  4017.   FImage.FTempHeight := 0;
  4018.   if Value <> 0 then
  4019.     with EnhHeader.rclFrame do
  4020.     begin
  4021.       FImage.FWidth := Right - Left;
  4022.       FImage.FHeight := Bottom - Top;
  4023.     end;
  4024.   PaletteModified := Palette <> 0;
  4025.   Changed(Self);
  4026. end;
  4027.  
  4028. procedure TMetafile.SetHeight(Value: Integer);
  4029. var
  4030.   EMFHeader: TEnhMetaHeader;
  4031. begin
  4032.   if FImage = nil then NewImage;
  4033.   with FImage do
  4034.     if FInch = 0 then
  4035.       if FHandle = 0 then
  4036.         FTempHeight := Value
  4037.       else
  4038.       begin                 { convert device pixels to 0.01mm units }
  4039.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4040.         MMHeight := MulDiv(Value,                      { metafile height in pixels }
  4041.           EMFHeader.szlMillimeters.cy*100,             { device height in 0.01mm }
  4042.           EMFHeader.szlDevice.cy);                     { device height in pixels }
  4043.       end
  4044.     else
  4045.       MMHeight := MulDiv(Value, 25400, ScreenLogPixels);
  4046. end;
  4047.  
  4048. procedure TMetafile.SetInch(Value: Word);
  4049. begin
  4050.   if FImage = nil then NewImage;
  4051.   if FImage.FInch <> Value then
  4052.   begin
  4053.     UniqueImage;
  4054.     FImage.FInch := Value;
  4055.     Changed(Self);
  4056.   end;
  4057. end;
  4058.  
  4059. procedure TMetafile.SetMMHeight(Value: Integer);
  4060. begin
  4061.   if FImage = nil then NewImage;
  4062.   FImage.FTempHeight := 0;
  4063.   if FImage.FHeight <> Value then
  4064.   begin
  4065.     UniqueImage;
  4066.     FImage.FHeight := Value;
  4067.     Changed(Self);
  4068.   end;
  4069. end;
  4070.  
  4071. procedure TMetafile.SetMMWidth(Value: Integer);
  4072. begin
  4073.   if FImage = nil then NewImage;
  4074.   FImage.FTempWidth := 0;
  4075.   if FImage.FWidth <> Value then
  4076.   begin
  4077.     UniqueImage;
  4078.     FImage.FWidth := Value;
  4079.     Changed(Self);
  4080.   end;
  4081. end;
  4082.  
  4083. procedure TMetafile.SetWidth(Value: Integer);
  4084. var
  4085.   EMFHeader: TEnhMetaHeader;
  4086. begin
  4087.   if FImage = nil then NewImage;
  4088.   with FImage do
  4089.     if FInch = 0 then
  4090.       if FHandle = 0 then
  4091.         FTempWidth := Value
  4092.       else
  4093.       begin                 { convert device pixels to 0.01mm units }
  4094.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4095.         MMWidth := MulDiv(Value,                      { metafile width in pixels }
  4096.           EMFHeader.szlMillimeters.cx*100,            { device width in mm }
  4097.           EMFHeader.szlDevice.cx);                    { device width in pixels }
  4098.       end
  4099.     else
  4100.       MMWidth := MulDiv(Value, 25400, ScreenLogPixels);
  4101. end;
  4102.  
  4103. function TMetafile.TestEMF(Stream: TStream): Boolean;
  4104. var
  4105.   Size: Longint;
  4106.   Header: TEnhMetaHeader;
  4107. begin
  4108.   Size := Stream.Size - Stream.Position;
  4109.   if Size > Sizeof(Header) then
  4110.   begin
  4111.     Stream.Read(Header, Sizeof(Header));
  4112.     Stream.Seek(-Sizeof(Header), soFromCurrent);
  4113.   end;
  4114.   Result := (Size > Sizeof(Header)) and
  4115.     (Header.iType = EMR_HEADER) and (Header.dSignature = ENHMETA_SIGNATURE);
  4116. end;
  4117.  
  4118. procedure TMetafile.UniqueImage;
  4119. var
  4120.   NewImage: TMetafileImage;
  4121. begin
  4122.   if FImage = nil then
  4123.     Self.NewImage
  4124.   else
  4125.     if FImage.FRefCount > 1 then
  4126.     begin
  4127.       NewImage:= TMetafileImage.Create;
  4128.       if FImage.FHandle <> 0 then
  4129.         NewImage.FHandle := CopyEnhMetafile(FImage.FHandle, nil);
  4130.       NewImage.FHeight := FImage.FHeight;
  4131.       NewImage.FWidth := FImage.FWidth;
  4132.       NewImage.FInch := FImage.FInch;
  4133.       NewImage.FTempWidth := FImage.FTempWidth;
  4134.       NewImage.FTempHeight := FImage.FTempHeight;
  4135.       FImage.Release;
  4136.       FImage := NewImage;
  4137.       FImage.Reference;
  4138.     end;
  4139. end;
  4140.  
  4141. procedure TMetafile.WriteData(Stream: TStream);
  4142. var
  4143.   SavePos: Longint;
  4144. begin
  4145.   if FImage <> nil then
  4146.   begin
  4147.     SavePos := 0;
  4148.     Stream.Write(SavePos, Sizeof(SavePos));
  4149.     SavePos := Stream.Position - Sizeof(SavePos);
  4150.     if Enhanced then
  4151.       WriteEMFStream(Stream)
  4152.     else
  4153.       WriteWMFStream(Stream);
  4154.     Stream.Seek(SavePos, soFromBeginning);
  4155.     SavePos := Stream.Size - SavePos;
  4156.     Stream.Write(SavePos, Sizeof(SavePos));
  4157.     Stream.Seek(0, soFromEnd);
  4158.   end;
  4159. end;
  4160.  
  4161. procedure TMetafile.WriteEMFStream(Stream: TStream);
  4162. var
  4163.   Buf: Pointer;
  4164.   Length: Longint;
  4165. begin
  4166.   if FImage = nil then Exit;
  4167.   Length := GetEnhMetaFileBits(FImage.FHandle, 0, nil);
  4168.   GetMem(Buf, Length);
  4169.   try
  4170.     GetEnhMetaFileBits(FImage.FHandle, Length, Buf);
  4171.     Stream.WriteBuffer(Buf^, Length);
  4172.   finally
  4173.     FreeMem(Buf, Length);
  4174.   end;
  4175. end;
  4176.  
  4177. procedure TMetafile.WriteWMFStream(Stream: TStream);
  4178. var
  4179.   WMF: TMetafileHeader;
  4180.   Bits: Pointer;
  4181.   Length: Longint;
  4182.   RefDC: HDC;
  4183. begin
  4184.   if FImage = nil then Exit;
  4185.   FillChar(WMF, SizeOf(WMF), 0);
  4186.   with FImage do
  4187.   begin
  4188.     with WMF do
  4189.     begin
  4190.       Key := WMFKEY;
  4191.       if FInch = 0 then
  4192.         Inch := 2540          { 2540 0.01mm units per inch }
  4193.       else
  4194.         Inch := FInch;
  4195.       with Box do
  4196.       begin
  4197.         Left := 0;
  4198.         Top := 0;
  4199.         Right := FWidth;
  4200.         Bottom := FHeight;
  4201.       end;
  4202.       CheckSum := ComputeAldusChecksum(WMF);
  4203.     end;
  4204.     RefDC := GetDC(0);
  4205.     try
  4206.       Length := GetWinMetaFileBits(FHandle, 0, nil, MM_ANISOTROPIC, RefDC);
  4207.       GetMem(Bits, Length);
  4208.       try
  4209.         if GetWinMetaFileBits(FHandle, Length, Bits, MM_ANISOTROPIC,
  4210.           RefDC) < Length then GDIError;
  4211.         Stream.WriteBuffer(WMF, SizeOf(WMF));
  4212.         Stream.WriteBuffer(Bits^, Length);
  4213.       finally
  4214.         FreeMem(Bits, Length);
  4215.       end;
  4216.     finally
  4217.       ReleaseDC(0, RefDC);
  4218.     end;
  4219.   end;
  4220. end;
  4221.  
  4222. procedure TMetafile.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  4223.   APalette: HPALETTE);
  4224. var
  4225.   EnhHeader: TEnhMetaHeader;
  4226. begin
  4227.   AData := GetClipboardData(CF_ENHMETAFILE); // OS will convert WMF to EMF
  4228.   if AData = 0 then  InvalidGraphic(SUnknownClipboardFormat);
  4229.   NewImage;
  4230.   with FImage do
  4231.   begin
  4232.     FHandle := CopyEnhMetafile(AData, nil);
  4233.     GetEnhMetaFileHeader(FHandle, sizeof(EnhHeader), @EnhHeader);
  4234.     with EnhHeader.rclFrame do
  4235.     begin
  4236.       FWidth := Right - Left;
  4237.       FHeight := Bottom - Top;
  4238.     end;
  4239.     FInch := 0;
  4240.   end;
  4241.   Enhanced := True;
  4242.   PaletteModified := Palette <> 0;
  4243.   Changed(Self);
  4244. end;
  4245.  
  4246. procedure TMetafile.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  4247.   var APalette: HPALETTE);
  4248. begin
  4249.   if FImage = nil then Exit;
  4250.   AFormat := CF_ENHMETAFILE;
  4251.   APalette := 0;
  4252.   AData := CopyEnhMetaFile(FImage.FHandle, nil);
  4253. end;
  4254.  
  4255. function TMetafile.ReleaseHandle: HENHMETAFILE;
  4256. begin
  4257.   UniqueImage;
  4258.   Result := FImage.FHandle;
  4259.   FImage.FHandle := 0;
  4260. end;
  4261.  
  4262. var
  4263.   BitmapCanvasList: TThreadList = nil;
  4264.  
  4265. { TBitmapCanvas }
  4266. { Create a canvas that gets its DC from the memory DC cache }
  4267. type
  4268.   TBitmapCanvas = class(TCanvas)
  4269.   private
  4270.     FBitmap: TBitmap;
  4271.     FOldBitmap: HBITMAP;
  4272.     FOldPalette: HPALETTE;
  4273.     procedure FreeContext;
  4274.   protected
  4275.     procedure CreateHandle; override;
  4276.   public
  4277.     constructor Create(ABitmap: TBitmap);
  4278.     destructor Destroy; override;
  4279.   end;
  4280.  
  4281. { FreeMemoryContexts is called by the VCL main winproc to release
  4282.   memory DCs after every message is processed (garbage collection).
  4283.   Only memory DCs not locked by other threads will be freed.
  4284.  
  4285.   The LockCount test below provides a hint as to whether the canvas is
  4286.   already locked, but this is not an absolute indicator.  If it is locked,
  4287.   we don't want to free the DC. If it is not currently locked, the canvas
  4288.   could be locked by another thread between this test and the lock which
  4289.   occurs inside FreeContext, in which case we wait for the other
  4290.   thread to unlock the canvas.
  4291. }
  4292. procedure FreeMemoryContexts;
  4293. var
  4294.   I: Integer;
  4295. begin
  4296.   with BitmapCanvasList.LockList do
  4297.   begin
  4298.     for I := Count-1 downto 0 do
  4299.     with TBitmapCanvas(Items[I]) do
  4300.       if LockCount = 0 then
  4301.         FreeContext;
  4302.   end;
  4303. end;
  4304.  
  4305. { DeselectBitmap is called to ensure that a bitmap handle is not
  4306.   selected into any memory DC anywhere in the system.  If the bitmap
  4307.   handle is in use by a locked canvas, DeselectBitmap must wait for
  4308.   the canvas to unlock. }
  4309.  
  4310. procedure DeselectBitmap(AHandle: HBITMAP);
  4311. var
  4312.   I: Integer;
  4313. begin
  4314.   if AHandle = 0 then Exit;
  4315.   with BitmapCanvasList.LockList do
  4316.     for I := Count - 1 downto 0 do
  4317.       with TBitmapCanvas(Items[I]) do
  4318.         if (FBitmap <> nil) and (FBitmap.FImage.FHandle = AHandle) then
  4319.           FreeContext;
  4320. end;
  4321.  
  4322. constructor TBitmapCanvas.Create(ABitmap: TBitmap);
  4323. begin
  4324.   inherited Create;
  4325.   FBitmap := ABitmap;
  4326. end;
  4327.  
  4328. destructor TBitmapCanvas.Destroy;
  4329. begin
  4330.   FreeContext;
  4331.   inherited Destroy;
  4332. end;
  4333.  
  4334. procedure TBitmapCanvas.FreeContext;
  4335. var
  4336.   H: HBITMAP;
  4337. begin
  4338.   if FHandle <> 0 then
  4339.   begin
  4340.     Lock;
  4341.     try
  4342.       if FOldBitmap <> 0 then SelectObject(FHandle, FOldBitmap);
  4343.       if FOldPalette <> 0 then SelectPalette(FHandle, FOldPalette, True);
  4344.       H := FHandle;
  4345.       Handle := 0;
  4346.       DeleteDC(H);
  4347.       BitmapCanvasList.Remove(Self);
  4348.     finally
  4349.       Unlock;
  4350.     end;
  4351.   end;
  4352. end;
  4353.  
  4354. procedure TBitmapCanvas.CreateHandle;
  4355. var
  4356.   H: HBITMAP;
  4357. begin
  4358.   if FBitmap <> nil then
  4359.   begin
  4360.     Lock;
  4361.     try
  4362.       FBitmap.HandleNeeded;
  4363.       DeselectBitmap(FBitmap.FImage.FHandle);
  4364.       FBitmap.PaletteNeeded;
  4365.       H := CreateCompatibleDC(0);
  4366.       if FBitmap.FImage.FHandle <> 0 then
  4367.         FOldBitmap := SelectObject(H, FBitmap.FImage.FHandle) else
  4368.         FOldBitmap := 0;
  4369.       if FBitmap.FImage.FPalette <> 0 then
  4370.       begin
  4371.         FOldPalette := SelectPalette(H, FBitmap.FImage.FPalette, True);
  4372.         RealizePalette(H);
  4373.       end
  4374.       else
  4375.         FOldPalette := 0;
  4376.       Handle := H;
  4377.       BitmapCanvasList.Add(Self);
  4378.     finally
  4379.       Unlock;
  4380.     end;
  4381.   end;
  4382. end;
  4383.  
  4384. { TSharedImage }
  4385.  
  4386. procedure TSharedImage.Reference;
  4387. begin
  4388.   Inc(FRefCount);
  4389. end;
  4390.  
  4391. procedure TSharedImage.Release;
  4392. begin
  4393.   if Pointer(Self) <> nil then
  4394.   begin
  4395.     Dec(FRefCount);
  4396.     if FRefCount = 0 then
  4397.     begin
  4398.       FreeHandle;
  4399.       Free;
  4400.     end;
  4401.   end;
  4402. end;
  4403.  
  4404. { TBitmapImage }
  4405.  
  4406. destructor TBitmapImage.Destroy;
  4407. begin
  4408.   if FDIBHandle <> 0 then
  4409.   begin
  4410.     DeselectBitmap(FDIBHandle);
  4411.     DeleteObject(FDIBHandle);
  4412.     FDIBHandle := 0;
  4413.   end;
  4414.   FreeHandle;
  4415.   if FDIB.dshSection <> 0 then CloseHandle(FDIB.dshSection);
  4416.   inherited Destroy;
  4417. end;
  4418.  
  4419. procedure TBitmapImage.FreeHandle;
  4420. begin
  4421.   if (FHandle <> 0) and (FHandle <> FDIBHandle) then
  4422.   begin
  4423.     DeselectBitmap(FHandle);
  4424.     DeleteObject(FHandle);
  4425.   end;
  4426.   InternalDeletePalette(FPalette);
  4427.   FHandle := 0;
  4428.   FPalette := 0;
  4429. end;
  4430.  
  4431. { TBitmap }
  4432.  
  4433. { This is defined in CommCtrl.pas - do we want to use it instead? }
  4434. type
  4435.   PColorMap = ^TColorMap;
  4436.   TColorMap = packed record
  4437.     cFrom: TColorRef;
  4438.     cTo: TColorRef;
  4439.   end;
  4440.   PColorMapArray = ^TColorMapArray;
  4441.   TColorMapArray = array[Byte] of TColorMap;
  4442.  
  4443. const
  4444.   { Mapping from color in DIB to system color }
  4445.   SysColors: array[0..3] of TColorMap = (
  4446.     (cFrom: $000000; cTo: clBtnText),
  4447.     (cFrom: $808080; cTo: clBtnShadow),
  4448.     (cFrom: $C0C0C0; cTo: clBtnFace),
  4449.     (cFrom: $FFFFFF; cTo: clBtnHighlight));
  4450.  
  4451. procedure UpdateDIBColorTable(DIBHandle: HBITMAP; Pal: HPalette;
  4452.   const DIB: TDIBSection);
  4453. var
  4454.   ScreenDC, DC: HDC;
  4455.   OldBM: HBitmap;
  4456.   ColorCount: Integer;
  4457.   Colors: array [Byte] of TRGBQuad;
  4458. begin
  4459.   if (DIBHandle <> 0) and (DIB.dsbmih.biBitCount <= 8) then
  4460.   begin
  4461.     ColorCount := PaletteToDIBColorTable(Pal, Colors);
  4462.     if ColorCount = 0 then Exit;
  4463.     ScreenDC := GetDC(0);
  4464.     DC := CreateCompatibleDC(ScreenDC);
  4465.     OldBM := SelectObject(DC, DIBHandle);
  4466.     try
  4467.       SetDIBColorTable(DC, 0, ColorCount, Colors);
  4468.     finally
  4469.       SelectObject(DC, OldBM);
  4470.       DeleteDC(DC);
  4471.       ReleaseDC(0, ScreenDC);
  4472.     end;
  4473.   end;
  4474. end;
  4475.  
  4476. function CreateMappedBmp(Handle: HBITMAP; const ColorMap; NumMaps: Integer): HBITMAP;
  4477. var
  4478.   Bitmap: PBitmapInfoHeader;
  4479.   ColorCount: Integer;
  4480.   BitmapInfoSize: Integer;
  4481.   BitmapBitsSize: Integer;
  4482.   Bits: Pointer;
  4483.   Colors: PRGBQuadArray;
  4484.   I, J: Integer;
  4485.   Color: TColorRef;
  4486.   ScreenDC, DC: HDC;
  4487.   Save: HBITMAP;
  4488. begin
  4489.   Result := 0;
  4490.   if Handle = 0 then Exit;
  4491.   InternalGetDIBSizes(Handle, BitmapInfoSize, BitmapBitsSize, 0);
  4492.   Bitmap := AllocMem(BitmapInfoSize + BitmapBitsSize);
  4493.   try
  4494.     Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
  4495.     InternalGetDIB(Handle, 0, Bitmap^, Bits^, 0);
  4496.     if Bitmap^.biBitCount <= 8 then
  4497.     begin
  4498.       ColorCount := 1 shl (Bitmap^.biBitCount);
  4499.       Colors := Pointer(Integer(Bitmap) + Bitmap^.biSize);
  4500.       { Replace button-face and button-shadow colors with the current values. }
  4501.       for I := 0 to ColorCount - 1 do
  4502.         for J := 0 to NumMaps - 1 do
  4503.           if TColorRef(Colors[I]) and $FFFFFF = PColorMapArray(@ColorMap)[J].cFrom then
  4504.           begin
  4505.             Color := ColorToRGB(PColorMapArray(@ColorMap)[J].cTo);
  4506.             { Convert BGR to RGB }
  4507.             Colors[I].rgbRed := PRGBTriple(@Color)^.rgbtBlue;
  4508.             Colors[I].rgbGreen := PRGBTriple(@Color)^.rgbtGreen;
  4509.             Colors[I].rgbBlue := PRGBTriple(@Color)^.rgbtRed;
  4510.             Break;
  4511.           end;
  4512.       ScreenDC := GetDC(0);
  4513.       try
  4514.         DC := CreateCompatibleDC(ScreenDC);
  4515.         if DC <> 0 then
  4516.           with Bitmap^ do
  4517.           begin
  4518.             Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
  4519.             if Result <> 0 then
  4520.             begin
  4521.               Save := SelectObject(DC, Result);
  4522.               StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
  4523.                 Bits, PBitmapInfo(Bitmap)^, DIB_RGB_COLORS, SRCCOPY);
  4524.               SelectObject(DC, Save);
  4525.             end;
  4526.           end;
  4527.           DeleteObject(DC);
  4528.       finally
  4529.         ReleaseDC(0, ScreenDC);
  4530.       end;
  4531.     end;
  4532.   finally
  4533.     FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
  4534.   end;
  4535. end;
  4536.  
  4537. function CreateSysMappedBmp(Handle: HBITMAP): HBITMAP;
  4538. begin
  4539.   Result := CreateMappedBmp(Handle, SysColors, SizeOf(SysColors) div SizeOf(TColorMap));
  4540. end;
  4541.  
  4542. function CreateMappedRes(Instance: THandle; ResName: PChar; const ColorMap;
  4543.   NumMaps: Integer): HBITMAP;
  4544. var
  4545.   Rsrc: HRSRC;
  4546.   Res: THandle;
  4547.   ColorCount: Integer;
  4548.   BitmapInfoSize: Integer;
  4549.   Bitmap: PBitmapInfoHeader;
  4550.   BitmapInfo: PBitmapInfoHeader;
  4551.   Colors: PRGBQuadArray;
  4552.   I, J: Integer;
  4553.   Color: TColorRef;
  4554.   Bits: Pointer;
  4555.   ScreenDC, DC: HDC;
  4556.   Save: HBITMAP;
  4557. begin
  4558.   Result := 0;
  4559.   Rsrc := FindResource(Instance, ResName, RT_BITMAP);
  4560.   if Rsrc = 0 then Exit;
  4561.   Res := LoadResource(Instance, Rsrc);
  4562.   try
  4563.     { Lock the bitmap and get a pointer to the color table. }
  4564.     Bitmap := LockResource(Res);
  4565.     if Bitmap <> nil then
  4566.     try
  4567.       if Bitmap^.biBitCount <= 8 then
  4568.       begin
  4569.         ColorCount := 1 shl (Bitmap^.biBitCount);
  4570.         BitmapInfoSize := Bitmap^.biSize + ColorCount * SizeOf(TRGBQuad);
  4571.         GetMem(BitmapInfo, BitmapInfoSize);
  4572.         try
  4573.           if BitmapInfo = nil then Exit;
  4574.           Move(Bitmap^, BitmapInfo^, BitmapInfoSize);
  4575.           Colors := Pointer(Integer(BitmapInfo) + BitmapInfo^.biSize);
  4576.           { Replace button-face and button-shadow colors with the current values. }
  4577.           for I := 0 to ColorCount - 1 do
  4578.             for J := 0 to NumMaps - 1 do
  4579.               if TColorRef(Colors[I]) and $FFFFFF = PColorMapArray(@ColorMap)[J].cFrom then
  4580.               begin
  4581.                 Color := ColorToRGB(PColorMapArray(@ColorMap)[J].cTo);
  4582.                 { Convert BGR to RGB }
  4583.                 Colors[I].rgbRed := PRGBTriple(@Color)^.rgbtBlue;
  4584.                 Colors[I].rgbGreen := PRGBTriple(@Color)^.rgbtGreen;
  4585.                 Colors[I].rgbBlue := PRGBTriple(@Color)^.rgbtRed;
  4586.                 Break;
  4587.               end;
  4588.           { First skip over the header structure and color table entries, if any. }
  4589.           Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
  4590.           { Create a color bitmap compatible with the display device. }
  4591.           ScreenDC := GetDC(0);
  4592.           try
  4593.             DC := CreateCompatibleDC(ScreenDC);
  4594.             if DC <> 0 then
  4595.               with BitmapInfo^ do
  4596.               begin
  4597.                 Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
  4598.                 if Result <> 0 then
  4599.                 begin
  4600.                   Save := SelectObject(DC, Result);
  4601.                   StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
  4602.                     Bits, PBitmapInfo(BitmapInfo)^, DIB_RGB_COLORS, SRCCOPY);
  4603.                   SelectObject(DC, Save);
  4604.                 end;
  4605.               end;
  4606.               DeleteObject(DC);
  4607.           finally
  4608.             ReleaseDC(0, ScreenDC);
  4609.           end;
  4610.         finally
  4611.           FreeMem(BitmapInfo, BitmapInfoSize);
  4612.         end;
  4613.       end;
  4614.     finally
  4615.       UnlockResource(Res);
  4616.     end;
  4617.   finally
  4618.     FreeResource(Res);
  4619.   end;
  4620. end;
  4621.  
  4622. { !! Do we want to include CommCtrl.pas ?? }
  4623. function CreateSysMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
  4624. begin
  4625.   Result := CreateMappedRes(Instance, ResName, SysColors,
  4626.    SizeOf(SysColors) div SizeOf(TColorMap));
  4627. end;
  4628.  
  4629. function CopyBitmap(Handle: HBITMAP; Palette: HPALETTE; var DIB: TDIBSection;
  4630.   Canvas: TCanvas): HBITMAP;
  4631. var
  4632.   OldScr, NewScr: HBITMAP;
  4633.   ScreenDC, NewImageDC, OldImageDC: HDC;
  4634.   BI: PBitmapInfo;
  4635.   BitsMem: Pointer;
  4636.   SrcDIB: TDIBSection;
  4637.   MonoColors: array [0..1] of Integer;
  4638. begin
  4639.   Result := 0;
  4640.   if Handle = 0 then
  4641.     with DIB, dsbm, dsbmih do
  4642.     begin
  4643.       if (biSize <> 0) and ((biWidth = 0) or (biHeight = 0)) then Exit;
  4644.       if (biSize = 0) and ((bmWidth = 0) or (bmHeight = 0)) then Exit;
  4645.     end;
  4646.  
  4647.   DeselectBitmap(Handle);
  4648.  
  4649.   SrcDIB.dsbmih.biSize := 0;
  4650.   if Handle <> 0 then
  4651.     if GetObject(Handle, sizeof(SrcDIB), @SrcDIB) < sizeof(SrcDIB.dsbm) then
  4652.       InvalidBitmap;
  4653.  
  4654.   ScreenDC := GDICheck(GetDC(0));
  4655.   NewImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
  4656.   with DIB.dsbm do
  4657.   try
  4658.     if DIB.dsbmih.biSize < sizeof(DIB.dsbmih) then
  4659.       if (bmPlanes or bmBitsPixel) = 1 then // monochrome
  4660.         Result := GDICheck(CreateBitmap(bmWidth, bmHeight, 1, 1, nil))
  4661.       else  // Create DDB
  4662.         Result := GDICheck(CreateCompatibleBitmap(ScreenDC, bmWidth, bmHeight))
  4663.     else  // Create DIB
  4664.     begin
  4665.       GetMem(BI, sizeof(TBitmapInfo) + 256 * sizeof(TRGBQuad));
  4666.       with DIB.dsbmih do
  4667.       try
  4668.         biSize := sizeof(BI.bmiHeader);
  4669.         biPlanes := 1;
  4670.         BI.bmiHeader := DIB.dsbmih;
  4671.         bmWidth := biWidth;
  4672.         bmHeight := biHeight;
  4673.         if (biBitCount <= 8) then
  4674.         begin
  4675.           if (biBitCount = 1) and (SrcDIB.dsbm.bmBits = nil) then
  4676.           begin  // set mono DIB to white/black when converting from DDB.
  4677.             Integer(BI^.bmiColors[0]) := 0;
  4678.             PInteger(Integer(@BI^.bmiColors) + sizeof(Integer))^ := $FFFFFF;
  4679.           end
  4680.           else if (Palette <> 0) then
  4681.             PaletteToDIBColorTable(Palette, PRGBQuadArray(@BI.bmiColors)^)
  4682.           else if Handle <> 0 then
  4683.           begin
  4684.             NewScr := SelectObject(NewImageDC, Handle);
  4685.             if (SrcDIB.dsbmih.biSize > 0) and (SrcDIB.dsbm.bmBits <> nil) then
  4686.               biClrUsed := GetDIBColorTable(NewImageDC, 0, 256, BI^.bmiColors)
  4687.             else
  4688.               GetDIBits(ScreenDC, Handle, 0, Abs(biHeight), nil, BI^, DIB_RGB_COLORS);
  4689.             SelectObject(NewImageDC, NewScr);
  4690.           end;
  4691.         end
  4692.         else if ((biBitCount = 16) or (biBitCount = 32)) and
  4693.           ((biCompression and BI_BITFIELDS) <> 0) then
  4694.           Move(DIB.dsBitFields, BI.bmiColors, sizeof(DIB.dsBitFields));
  4695.         Result := GDICheck(CreateDIBSection(ScreenDC, BI^, DIB_RGB_COLORS, BitsMem, 0, 0));
  4696.         if (BitsMem = nil) then GDIError;
  4697.         if (Handle <> 0) and (SrcDIB.dsbm.bmWidth = biWidth) and
  4698.           (SrcDIB.dsbm.bmHeight = biHeight) then
  4699.         begin
  4700.           GetDIBits(ScreenDC, Handle, 0, Abs(biHeight), BitsMem, BI^, DIB_RGB_COLORS);
  4701.           Exit;
  4702.         end;
  4703.       finally
  4704.         FreeMem(BI);
  4705.       end;
  4706.     end;
  4707.  
  4708.     GDICheck(Result);
  4709.     NewScr := GDICheck(SelectObject(NewImageDC, Result));
  4710.     try
  4711.       try
  4712.         if Canvas <> nil then
  4713.         begin
  4714.           FillRect(NewImageDC, Rect(0, 0, bmWidth, bmHeight),
  4715.             Canvas.Brush.Handle);
  4716.           SetTextColor(NewImageDC, ColorToRGB(Canvas.Font.Color));
  4717.           SetBkColor(NewImageDC, ColorToRGB(Canvas.Brush.Color));
  4718.           if (DIB.dsbmih.biBitCount = 1) and (DIB.dsbm.bmBits <> nil) then
  4719.           begin
  4720.             MonoColors[0] := ColorToRGB(Canvas.Font.Color);
  4721.             MonoColors[1] := ColorToRGB(Canvas.Brush.Color);
  4722.             SetDIBColorTable(NewImageDC, 0, 2, MonoColors);
  4723.           end;
  4724.         end
  4725.         else
  4726.           PatBlt(NewImageDC, 0, 0, bmWidth, bmHeight, WHITENESS);
  4727.         if Handle <> 0 then
  4728.         begin
  4729.           OldImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
  4730.           try
  4731.             OldScr := GDICheck(SelectObject(OldImageDC, Handle));
  4732.             if Palette <> 0 then
  4733.             begin
  4734.               SelectPalette(OldImageDC, Palette, True);
  4735.               RealizePalette(OldImageDC);
  4736.               SelectPalette(NewImageDC, Palette, True);
  4737.               RealizePalette(NewImageDC);
  4738.             end;
  4739.             if Canvas <> nil then
  4740.             begin
  4741.               SetTextColor(OldImageDC, ColorToRGB(Canvas.Font.Color));
  4742.               SetBkColor(OldImageDC, ColorToRGB(Canvas.Brush.Color));
  4743.             end;
  4744.             BitBlt(NewImageDC, 0, 0, bmWidth, bmHeight, OldImageDC, 0, 0, SRCCOPY);
  4745.             GDICheck(SelectObject(OldImageDC, OldScr));
  4746.           finally
  4747.             DeleteDC(OldImageDC);
  4748.           end;
  4749.         end;
  4750.       finally
  4751.         SelectObject(NewImageDC, NewScr);
  4752.       end;
  4753.     except
  4754.       DeleteObject(Result);
  4755.       raise;
  4756.     end;
  4757.   finally
  4758.     DeleteDC(NewImageDC);
  4759.     ReleaseDC(0, ScreenDC);
  4760.     if (Result <> 0) then GetObject(Result, sizeof(DIB), @DIB);
  4761.   end;
  4762. end;
  4763.  
  4764. function CopyPalette(Palette: HPALETTE): HPALETTE;
  4765. var
  4766.   PaletteSize: Integer;
  4767.   LogPal: TMaxLogPalette;
  4768. begin
  4769.   Result := 0;
  4770.   if Palette = 0 then Exit;
  4771.   PaletteSize := 0;
  4772.   if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  4773.   if PaletteSize = 0 then Exit;
  4774.   with LogPal do
  4775.   begin
  4776.     palVersion := $0300;
  4777.     palNumEntries := PaletteSize;
  4778.     GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
  4779.   end;
  4780.   Result := CreatePalette(PLogPalette(@LogPal)^);
  4781. end;
  4782.  
  4783. constructor TBitmap.Create;
  4784. begin
  4785.   inherited Create;
  4786.   FImage := TBitmapImage.Create;
  4787.   FImage.Reference;
  4788. end;
  4789.  
  4790. destructor TBitmap.Destroy;
  4791. begin
  4792.   FreeContext;
  4793.   FImage.Release;
  4794.   FCanvas.Free;
  4795.   inherited Destroy;
  4796. end;
  4797.  
  4798. procedure TBitmap.Assign(Source: TPersistent);
  4799. var
  4800.   DIB: TDIBSection;
  4801. begin
  4802.   if (Source = nil) or (Source is TBitmap) then
  4803.   begin
  4804.     EnterCriticalSection(BitmapImageLock);
  4805.     try
  4806.       if Source <> nil then
  4807.       begin
  4808.         TBitmap(Source).FImage.Reference;
  4809.         FImage.Release;
  4810.         FImage := TBitmap(Source).FImage;
  4811.       end
  4812.       else
  4813.       begin
  4814.         FillChar(DIB, Sizeof(DIB), 0);
  4815.         NewImage(0, 0, DIB, False);
  4816.       end;
  4817.     finally
  4818.       LeaveCriticalSection(BitmapImageLock);
  4819.     end;
  4820.     PaletteModified := Palette <> 0;
  4821.     Changed(Self);
  4822.   end
  4823.   else inherited Assign(Source);
  4824. end;
  4825.  
  4826. procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
  4827. var
  4828.   NewHandle, NewPalette: THandle;
  4829. begin
  4830.   FreeContext;
  4831.   NewHandle := 0;
  4832.   NewPalette := 0;
  4833.   try
  4834.     NewHandle := CopyBitmap(AHandle, APalette, DIB, FCanvas);
  4835.     if APalette = SystemPalette16 then
  4836.       NewPalette := APalette
  4837.     else
  4838.       NewPalette := CopyPalette(APalette);
  4839.     NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
  4840.   except
  4841.     InternalDeletePalette(NewPalette);
  4842.     if NewHandle <> 0 then DeleteObject(NewHandle);
  4843.     raise;
  4844.   end;
  4845. end;
  4846.  
  4847. { Called by the FCanvas whenever an operation is going to be performed on the
  4848.   bitmap that would modify it.  Since modifications should only affect this
  4849.   TBitmap, the handle needs to be 'cloned' if it is being refered to by more
  4850.   than one TBitmap }
  4851. procedure TBitmap.Changing(Sender: TObject);
  4852. begin
  4853.   FreeImage;
  4854. end;
  4855.  
  4856. procedure TBitmap.Dormant;
  4857. begin
  4858.   DIBNeeded;
  4859.   FImage.FreeHandle;
  4860. end;
  4861.  
  4862. procedure TBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
  4863. var
  4864.   OldPalette: HPalette;
  4865.   RestorePalette: Boolean;
  4866.   DoHalftone: Boolean;
  4867.   Pt: TPoint;
  4868. begin
  4869.   with Rect, FImage do
  4870.   begin
  4871.     ACanvas.RequiredState(csAllValid);
  4872.     PaletteNeeded;
  4873.     OldPalette := 0;
  4874.     RestorePalette := False;
  4875.     if FPalette <> 0 then
  4876.     begin
  4877.       OldPalette := SelectPalette(ACanvas.FHandle, FPalette, True);
  4878.       RealizePalette(ACanvas.FHandle);
  4879.       RestorePalette := True;
  4880.     end;
  4881.     DoHalftone := ((GetDeviceCaps(ACanvas.FHandle, BITSPIXEL) *
  4882.       GetDeviceCaps(ACanvas.FHandle, PLANES)) <
  4883.       (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
  4884.     if DoHalftone then
  4885.     begin
  4886.       GetBrushOrgEx(ACanvas.FHandle, pt);
  4887.       SetStretchBltMode(ACanvas.FHandle, HALFTONE);
  4888.       SetBrushOrgEx(ACanvas.FHandle, pt.x, pt.y, @pt);
  4889.     end else if not Monochrome then
  4890.       SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
  4891.     try
  4892.       Canvas.RequiredState(csAllValid);
  4893.       StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
  4894.         Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
  4895.         FDIB.dsbm.bmHeight, ACanvas.CopyMode);
  4896.     finally
  4897.       if RestorePalette then
  4898.         SelectPalette(ACanvas.FHandle, OldPalette, True);
  4899.     end;
  4900.   end;
  4901. end;
  4902.  
  4903. { FreeImage:
  4904.   If there are multiple references to the image, create a unique copy of the image.
  4905.   If FHandle = FDIBHandle, the DIB memory will be updated when the drawing
  4906.   handle is drawn upon, so no changes are needed to maintain image integrity.
  4907.   If FHandle <> FDIBHandle, the DIB will not track with changes made to
  4908.   the DDB, so destroy the DIB handle (but keep the DIB pixel format info).  }
  4909. procedure TBitmap.FreeImage;
  4910. begin
  4911.   with FImage do
  4912.     if FRefCount > 1 then
  4913.     begin
  4914.       HandleNeeded;
  4915.       CopyImage(FHandle, FPalette, FDIB)
  4916.     end
  4917.     else if FHandle <> FDIBHandle then
  4918.     begin
  4919.       if FDIBHandle <> 0 then
  4920.         if not DeleteObject(FDIBHandle) then GDIError;
  4921.       FDIBHandle := 0;
  4922.       FDIB.dsbm.bmBits := nil;
  4923.     end;
  4924. end;
  4925.  
  4926. function TBitmap.GetEmpty;
  4927. begin
  4928.   with FImage do
  4929.     Result := (FHandle = 0) and (FDIBHandle = 0);
  4930. end;
  4931.  
  4932. function TBitmap.GetCanvas: TCanvas;
  4933. begin
  4934.   if FCanvas = nil then
  4935.   begin
  4936.     HandleNeeded;
  4937.     FCanvas := TBitmapCanvas.Create(Self);
  4938.     FCanvas.OnChange := Changed;
  4939.     FCanvas.OnChanging := Changing;
  4940.   end;
  4941.   Result := FCanvas;
  4942. end;
  4943.  
  4944. { Since the user might modify the contents of the HBITMAP it must not be
  4945.   shared by another TBitmap when given to the user nor should it be selected
  4946.   into a DC. }
  4947. function TBitmap.GetHandle: HBITMAP;
  4948. begin
  4949.   FreeContext;
  4950.   HandleNeeded;
  4951.   Changing(Self);
  4952.   Result := FImage.FHandle;
  4953. end;
  4954.  
  4955. function TBitmap.GetHandleType: TBitmapHandleType;
  4956. begin
  4957.   with FImage do
  4958.   begin
  4959.     if (FHandle = 0) or (FHandle = FDIBHandle) then
  4960.       if FDIBHandle = 0 then
  4961.         if FDIB.dsbmih.biSize = 0 then
  4962.           Result := bmDDB
  4963.         else
  4964.           Result := bmDIB
  4965.       else
  4966.         Result := bmDIB
  4967.     else
  4968.       Result := bmDDB;
  4969.   end;
  4970. end;
  4971.  
  4972. function TBitmap.GetHeight: Integer;
  4973. begin
  4974.   Result := Abs(FImage.FDIB.dsbm.bmHeight);
  4975. end;
  4976.  
  4977. function TBitmap.GetMonochrome: Boolean;
  4978. begin
  4979.   with FImage.FDIB.dsbm do
  4980.     Result := (bmPlanes = 1) and (bmBitsPixel = 1);
  4981. end;
  4982.  
  4983. function TBitmap.GetPalette: HPALETTE;
  4984. begin
  4985.   PaletteNeeded;
  4986.   Result := FImage.FPalette;
  4987. end;
  4988.  
  4989. function TBitmap.GetPixelFormat: TPixelFormat;
  4990. begin
  4991.   Result := pfCustom;
  4992.   if HandleType = bmDDB then
  4993.     Result := pfDevice
  4994.   else
  4995.     with FImage.FDIB, dsbmih do
  4996.       case biBitCount of
  4997.         1: Result := pf1Bit;
  4998.         4: Result := pf4Bit;
  4999.         8: Result := pf8Bit;
  5000.        16: case biCompression of
  5001.              BI_RGB : Result := pf15Bit;
  5002.              BI_BITFIELDS: if dsBitFields[1] = $7E0 then Result := pf16Bit;
  5003.            end;
  5004.        24: Result := pf24Bit;
  5005.        32: if biCompression = BI_RGB then Result := pf32Bit;
  5006.       end;
  5007. end;
  5008.  
  5009. function TBitmap.GetScanLine(Row: Integer): Pointer;
  5010. begin
  5011.   with FImage.FDIB, dsbm, dsbmih do
  5012.   begin
  5013.     if (Row < 0) or (Row > bmHeight) then
  5014.       InvalidOperation(SScanLine);
  5015.     DIBNeeded;
  5016.     GDIFlush;
  5017.     if biHeight > 0 then  // bottom-up DIB
  5018.       Row := biHeight - Row - 1;
  5019.     Integer(Result) := Integer(bmBits) +
  5020.       Row * BytesPerScanline(biWidth, biBitCount, 32);
  5021.   end;
  5022. end;
  5023.  
  5024. function TBitmap.GetTransparentColor: TColor;
  5025. begin
  5026.   if Monochrome then
  5027.     Result := clWhite
  5028.   else
  5029.     Result := Canvas.Pixels[0, Height - 1];
  5030.   Result := Result or $02000000;
  5031. end;
  5032.  
  5033. function TBitmap.GetWidth: Integer;
  5034. begin
  5035.   Result := FImage.FDIB.dsbm.bmWidth;
  5036. end;
  5037.  
  5038. procedure TBitmap.DIBNeeded;
  5039. begin
  5040.   with FImage do
  5041.   begin
  5042.     if (FHandle = 0) or (FDIBHandle <> 0) then Exit;
  5043.     PaletteNeeded;
  5044.     if FDIB.dsbmih.biSize = 0 then
  5045.     begin
  5046.       GetObject(FHandle, sizeof(FDIB), @FDIB);
  5047.       with FDIB, dsbm, dsbmih do
  5048.       begin
  5049.         biSize := sizeof(dsbmih);
  5050.         biWidth := bmWidth;
  5051.         biHeight := bmHeight;
  5052.         biPlanes := 1;
  5053.         biBitCount := bmPlanes * bmBitsPixel;
  5054.       end;
  5055.     end;
  5056.     FDIBHandle := CopyBitmap(FHandle, FPalette, FDIB, nil);
  5057.   end;
  5058. end;
  5059.  
  5060. procedure TBitmap.FreeContext;
  5061. begin
  5062.   if (FCanvas <> nil) then TBitmapCanvas(FCanvas).FreeContext;
  5063. end;
  5064.  
  5065. procedure TBitmap.HandleNeeded;
  5066. begin
  5067.   with FImage do
  5068.     if FHandle = 0 then
  5069.       FHandle := FDIBHandle;
  5070. end;
  5071.  
  5072. procedure TBitmap.PaletteNeeded;
  5073. var
  5074.   DC: HDC;
  5075. begin
  5076.   with FImage do
  5077.   begin
  5078.     if FIgnorePalette or (FPalette <> 0) or (FDIBHandle = 0) then Exit;
  5079.     if FHandle = FDIBHandle then DeselectBitmap(FDIBHandle);
  5080.     FPalette := PaletteFromDIBColorTable(FDIBHandle, nil, 1 shl FDIB.dsbmih.biBitCount);
  5081.     if FPalette <> 0 then Exit;
  5082.     DC := GDICheck(GetDC(0));
  5083.     FHalftone := FHalftone or
  5084.       ((GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <
  5085.       (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
  5086.     if FHalftone then FPalette := CreateHalftonePalette(DC);
  5087.     ReleaseDC(0, DC);
  5088.     if FPalette = 0 then IgnorePalette := True;
  5089.   end;
  5090. end;
  5091.  
  5092. procedure TBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  5093.   APalette: HPALETTE);
  5094. var
  5095.   DIB: TDIBSection;
  5096. begin
  5097.   if (AFormat <> CF_BITMAP) or (AData = 0) then
  5098.     InvalidGraphic(SUnknownClipboardFormat);
  5099.   FreeContext;
  5100.   FillChar(DIB, sizeof(DIB), 0);
  5101.   GetObject(AData, sizeof(DIB), @DIB);
  5102.   if DIB.dsbm.bmBits = nil then DIB.dsbmih.biSize := 0;
  5103.   CopyImage(AData, APalette, DIB);
  5104.   FImage.FOS2Format := False;
  5105.   PaletteModified := Palette <> 0;
  5106.   Changed(Self);
  5107. end;
  5108.  
  5109. procedure TBitmap.LoadFromStream(Stream: TStream);
  5110. begin
  5111.   ReadStream(Stream, Stream.Size - Stream.Position);
  5112. end;
  5113.  
  5114. procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
  5115. var
  5116.   Stream: TCustomMemoryStream;
  5117. begin
  5118.   Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
  5119.   try
  5120.     ReadDIB(Stream, Stream.Size);
  5121.   finally
  5122.     Stream.Free;
  5123.   end;
  5124. end;
  5125.  
  5126. procedure TBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
  5127. var
  5128.   Stream: TCustomMemoryStream;
  5129. begin
  5130.   Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
  5131.   try
  5132.     ReadDIB(Stream, Stream.Size);
  5133.   finally
  5134.     Stream.Free;
  5135.   end;
  5136. end;
  5137.  
  5138. procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  5139.   const NewDIB: TDIBSection; OS2Format: Boolean);
  5140. var
  5141.   Image: TBitmapImage;
  5142. begin
  5143.   Image := TBitmapImage.Create;
  5144.   with Image do
  5145.   try
  5146.     FHandle := NewHandle;
  5147.     FPalette := NewPalette;
  5148.     FDIB := NewDIB;
  5149.     FOS2Format := OS2Format;
  5150.     if FDIB.dsbm.bmBits <> nil then FDIBHandle := FHandle;
  5151.   except
  5152.     Image.Free;
  5153.     raise;
  5154.   end;
  5155.   EnterCriticalSection(BitmapImageLock);
  5156.   try
  5157.     FImage.Release;
  5158.     FImage := Image;
  5159.     FImage.Reference;
  5160.   finally
  5161.     LeaveCriticalSection(BitmapImageLock);
  5162.   end;
  5163. end;
  5164.  
  5165. procedure TBitmap.ReadData(Stream: TStream);
  5166. var
  5167.   Size: Longint;
  5168. begin
  5169.   Stream.Read(Size, SizeOf(Size));
  5170.   ReadStream(Stream, Size);
  5171. end;
  5172.  
  5173. procedure TBitmap.ReadDIB(Stream: TStream; ImageSize: Longint);
  5174. const
  5175.   DIBPalSizes: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
  5176. var
  5177.   DC: HDC;
  5178.   BitsMem: Pointer;
  5179.   OS2Header: TBitmapCoreHeader;
  5180.   BitmapInfo: PBitmapInfo;
  5181.   ColorTable: Pointer;
  5182.   HeaderSize: Integer;
  5183.   SectionHandle: THandle;
  5184.   SectionOffset: Integer;
  5185.   OS2Format: Boolean;
  5186.   BMHandle: HBITMAP;
  5187.   DIB: TDIBSection;
  5188.   Pal: HPalette;
  5189. begin
  5190.   Pal := 0;
  5191.   Stream.Read(HeaderSize, sizeof(HeaderSize));
  5192.   OS2Format := HeaderSize = sizeof(OS2Header);
  5193.   if OS2Format then HeaderSize := sizeof(TBitmapInfoHeader);
  5194.   GetMem(BitmapInfo, HeaderSize + 256 * sizeof(TRGBQuad));
  5195.   with BitmapInfo^ do
  5196.   try
  5197.     if OS2Format then  // convert OS2 DIB to Win DIB
  5198.     begin
  5199.       Stream.Read(Pointer(Longint(@OS2Header) + sizeof(HeaderSize))^,
  5200.         sizeof(OS2Header) - sizeof(HeaderSize));
  5201.       FillChar(bmiHeader, sizeof(bmiHeader), 0);
  5202.       with bmiHeader, OS2Header do
  5203.       begin
  5204.         biWidth := bcWidth;
  5205.         biHeight := bcHeight;
  5206.         biPlanes := bcPlanes;
  5207.         biBitCount := bcBitCount;
  5208.       end;
  5209.       Dec(ImageSize, sizeof(OS2Header));
  5210.     end
  5211.     else
  5212.     begin // support bitmap headers larger than TBitmapInfoHeader
  5213.       Stream.Read(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
  5214.         HeaderSize - sizeof(HeaderSize));
  5215.       Dec(ImageSize, HeaderSize);
  5216.     end;
  5217.  
  5218.     with bmiHeader do
  5219.     begin
  5220.       biSize := HeaderSize;
  5221.       ColorTable := Pointer(Longint(BitmapInfo) + HeaderSize);
  5222.  
  5223.       { check number of planes. DIBs must be 1 color plane (packed pixels) }
  5224.       if biPlanes <> 1 then InvalidBitmap;
  5225.  
  5226.       // 3 DWORD color element bit masks (ie 888 or 565) can precede colors
  5227.       if (HeaderSize = sizeof(TBitmapInfoHeader)) and
  5228.         ((biBitCount = 16) or (biBitCount = 32)) and
  5229.         (biCompression = BI_BITFIELDS) then
  5230.       begin
  5231.         Stream.ReadBuffer(ColorTable^, 3 * sizeof(DWORD));
  5232.         Inc(Longint(ColorTable), 3 * sizeof(DWORD));
  5233.         Dec(ImageSize, 3 * sizeof(DWORD));
  5234.       end;
  5235.  
  5236.       // Read the color palette
  5237.       if biClrUsed = 0 then
  5238.         biClrUsed := GetDInColors(biBitCount);
  5239.       Stream.ReadBuffer(ColorTable^, biClrUsed * DIBPalSizes[OS2Format]);
  5240.       Dec(ImageSize, biClrUsed * DIBPalSizes[OS2Format]);
  5241.  
  5242.       // biSizeImage can be zero. If zero, compute the size.
  5243.       if biSizeImage = 0 then            // top-down DIBs have negative height
  5244.         biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
  5245.  
  5246.       if biSizeImage < ImageSize then ImageSize := biSizeImage;
  5247.     end;
  5248.  
  5249.     { convert OS2 color table to DIB color table }
  5250.     if OS2Format then RGBTripleToQuad(ColorTable^);
  5251.  
  5252. {!!    if (Stream is TMemoryMappedStream) then
  5253.     begin
  5254.       SectionHandle := Stream.Handle;
  5255.       SectionOffset := Stream.Position;
  5256.     end
  5257.     else
  5258. }   begin
  5259.       SectionHandle := 0;
  5260.       SectionOffset := 0;
  5261.     end;
  5262.  
  5263.     DC := GDICheck(GetDC(0));
  5264.     try
  5265.       BMHandle := CreateDIBSection(DC, BitmapInfo^, DIB_RGB_COLORS, BitsMem,
  5266.         SectionHandle, SectionOffset);
  5267.       if (BMHandle = 0) or (BitsMem = nil) then GDIError;
  5268.  
  5269.       try
  5270.         if SectionHandle = 0 then
  5271.           Stream.ReadBuffer(BitsMem^, ImageSize);
  5272.       except
  5273.         DeleteObject(BMHandle);
  5274.         raise;
  5275.       end;
  5276.     finally
  5277.       ReleaseDC(0, DC);
  5278.     end;
  5279.     // Hi-color DIBs don't preserve color table, so create palette now
  5280.     if (bmiHeader.biBitCount > 8) and (bmiHeader.biClrUsed > 0) then
  5281.       Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
  5282.   finally
  5283.     FreeMem(BitmapInfo);
  5284.   end;
  5285.   FillChar(DIB, sizeof(DIB), 0);
  5286.   GetObject(BMHandle, Sizeof(DIB), @DIB);
  5287.   NewImage(BMHandle, Pal, DIB, OS2Format);
  5288.   PaletteModified := Palette <> 0;
  5289.   Changed(Self);
  5290. end;
  5291.  
  5292. procedure TBitmap.ReadStream(Stream: TStream; Size: Longint);
  5293. var
  5294.   Bmf: TBitmapFileHeader;
  5295.   DIB: TDIBSection;
  5296. begin
  5297.   FreeContext;
  5298.   if Size = 0 then
  5299.   begin
  5300.     FillChar(DIB, sizeof(DIB), 0);
  5301.     NewImage(0, 0, DIB, False);
  5302.   end
  5303.   else
  5304.   begin
  5305.     Stream.ReadBuffer(Bmf, sizeof(Bmf));
  5306.     if Bmf.bfType <> $4D42 then InvalidBitmap;
  5307.     ReadDIB(Stream, Size - sizeof(Bmf));
  5308.   end;
  5309. end;
  5310.  
  5311. procedure TBitmap.SetHandle(Value: HBITMAP);
  5312. var
  5313.   DIB: TDIBSection;
  5314.   APalette: HPALETTE;
  5315. begin
  5316.   with FImage do
  5317.     if FHandle <> Value then
  5318.     begin
  5319.       FreeContext;
  5320.       FillChar(DIB, sizeof(DIB), 0);
  5321.       if Value <> 0 then
  5322.         GetObject(Value, SizeOf(DIB), @DIB);
  5323.       if FRefCount = 1 then
  5324.       begin
  5325.         APalette := FPalette;
  5326.         FPalette := 0;
  5327.       end
  5328.       else
  5329.         if FPalette = SystemPalette16 then
  5330.           APalette := SystemPalette16
  5331.         else
  5332.           APalette := CopyPalette(FPalette);
  5333.       try
  5334.         NewImage(Value, APalette, DIB, False);
  5335.       except
  5336.         InternalDeletePalette(APalette);
  5337.         raise;
  5338.       end;
  5339.       Changed(Self);
  5340.     end;
  5341. end;
  5342.  
  5343. procedure TBitmap.SetHandleType(Value: TBitmapHandleType);
  5344. var
  5345.   DIB: TDIBSection;
  5346.   AHandle: HBITMAP;
  5347.   APalette: HPALETTE;
  5348. begin
  5349.   if Value = GetHandleType then Exit;
  5350.   with FImage do
  5351.   begin
  5352.     if (FHandle = 0) and (FDIBHandle = 0) then
  5353.       if Value = bmDDB then
  5354.         FDIB.dsbmih.biSize := 0
  5355.       else
  5356.         FDIB.dsbmih.biSize := sizeof(FDIB.dsbmih)
  5357.     else
  5358.     begin
  5359.       if Value = bmDIB then
  5360.       begin
  5361.         if (FDIBHandle <> 0) and (FDIBHandle = FHandle) then Exit;
  5362.         FreeContext;
  5363.         PaletteNeeded;
  5364.         DIBNeeded;
  5365.         if FRefCount = 1 then
  5366.         begin
  5367.           AHandle := FDIBHandle;
  5368.           FDIBHandle := 0;
  5369.           APalette := FPalette;
  5370.           FPalette := 0;
  5371.           NewImage(AHandle, APalette, FDIB, FOS2Format);
  5372.         end
  5373.         else
  5374.           CopyImage(FDIBHandle, FPalette, FDIB);
  5375.       end
  5376.       else
  5377.       begin
  5378.         if (FHandle <> 0) and (FHandle <> FDIBHandle) then Exit;
  5379.         FreeContext;
  5380.         PaletteNeeded;
  5381.         DIB := FDIB;
  5382.         DIB.dsbmih.biSize := 0;   // flag to tell CopyBitmap to create a DDB
  5383.         AHandle := CopyBitmap(FDIBHandle, FPalette, DIB, nil);
  5384.         if FRefCount = 1 then
  5385.           FHandle := AHandle
  5386.         else
  5387.         begin
  5388.           APalette := CopyPalette(FPalette);
  5389.           NewImage(AHandle, APalette, DIB, FOS2Format);
  5390.         end;
  5391.       end;
  5392.       Changed(Self);
  5393.     end;
  5394.   end;
  5395. end;
  5396.  
  5397. procedure TBitmap.SetHeight(Value: Integer);
  5398. var
  5399.   DIB: TDIBSection;
  5400. begin
  5401.   with FImage do
  5402.     if FDIB.dsbm.bmHeight <> Value then
  5403.     begin
  5404.       HandleNeeded;
  5405.       DIB := FDIB;
  5406.       DIB.dsbm.bmHeight := Value;
  5407.       DIB.dsbmih.biHeight := Value;
  5408.       CopyImage(FHandle, FPalette, DIB);
  5409.       Changed(Self);
  5410.     end;
  5411. end;
  5412.  
  5413. procedure TBitmap.SetMonochrome(Value: Boolean);
  5414. var
  5415.   DIB: TDIBSection;
  5416. begin
  5417.   with FImage, FDIB.dsbmih do
  5418.     if Value <> ((biPlanes = 1) and (biBitCount = 1)) then
  5419.     begin
  5420.       HandleNeeded;
  5421.       DIB := FDIB;
  5422.       with DIB.dsbmih, DIB.dsbm do
  5423.       begin
  5424.         biSize := 0;   // request DDB handle
  5425.         biPlanes := Byte(Value);  // 0 = request screen BMP format
  5426.         biBitCount := Byte(Value);
  5427.         bmPlanes := Byte(Value);
  5428.         bmBitsPixel := Byte(Value);
  5429.       end;
  5430.       CopyImage(FHandle, FPalette, DIB);
  5431.       Changed(Self);
  5432.     end;
  5433. end;
  5434.  
  5435. procedure TBitmap.SetPalette(Value: HPALETTE);
  5436. var
  5437.   AHandle: HBITMAP;
  5438.   DIB: TDIBSection;
  5439. begin
  5440.   if FImage.FPalette <> Value then
  5441.   begin
  5442.     with FImage do
  5443.     begin
  5444.       FreeContext;
  5445.       HandleNeeded;
  5446.       DIB := FDIB;
  5447.       if FRefCount = 1 then
  5448.       begin
  5449.         AHandle := FHandle;
  5450.         if FHandle = FDIBHandle then
  5451.           FDIBHandle := 0;
  5452.         FHandle := 0;
  5453.       end
  5454.       else
  5455.         AHandle := CopyBitmap(FHandle, FPalette, DIB, nil);
  5456.       try
  5457.         NewImage(AHandle, Value, DIB, FOS2Format);
  5458.       except
  5459.         DeleteObject(AHandle);
  5460.         raise;
  5461.       end;
  5462.     end;
  5463.     UpdateDIBColorTable(FImage.FDIBHandle, Value, FImage.FDIB);
  5464.     PaletteModified := True;
  5465.     Changed(Self);
  5466.   end;
  5467. end;
  5468.  
  5469. procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
  5470. const
  5471.   BitCounts: array [pf1Bit..pf32Bit] of Byte = (1,4,8,16,16,24,32);
  5472. var
  5473.   DIB: TDIBSection;
  5474.   Pal: HPalette;
  5475.   DC: HDC;
  5476. begin
  5477.   if Value = GetPixelFormat then Exit;
  5478.   case Value of
  5479.     pfDevice:
  5480.       begin
  5481.         HandleType := bmDDB;
  5482.         Exit;
  5483.       end;
  5484.     pfCustom: InvalidGraphic(SInvalidPixelFormat);
  5485.   else
  5486.     FillChar(DIB, sizeof(DIB), 0);
  5487.     DIB.dsbm := FImage.FDIB.dsbm;
  5488.     with DIB, dsbm, dsbmih do
  5489.     begin
  5490.       biSize := sizeof(DIB.dsbmih);
  5491.       biWidth := bmWidth;
  5492.       biHeight := bmHeight;
  5493.       biPlanes := 1;
  5494.       biBitCount := BitCounts[Value];
  5495.       Pal := 0;
  5496.       case Value of
  5497.         pf4Bit: Pal := SystemPalette16;
  5498.         pf8Bit:
  5499.           begin
  5500.             DC := GDICheck(GetDC(0));
  5501.             Pal := CreateHalftonePalette(DC);
  5502.             ReleaseDC(0, DC);
  5503.           end;
  5504.         pf16Bit:
  5505.           begin
  5506.             biCompression := BI_BITFIELDS;
  5507.             dsBitFields[0] := $F800;
  5508.             dsBitFields[1] := $07E0;
  5509.             dsBitFields[2] := $001F;
  5510.           end;
  5511.       end;
  5512.       NewImage(0, Pal, DIB, FImage.FOS2Format);
  5513.       PaletteModified := Pal <> 0;
  5514.       Changed(Self);
  5515.     end;
  5516.   end;
  5517. end;
  5518.  
  5519. procedure TBitmap.SetWidth(Value: Integer);
  5520. var
  5521.   DIB: TDIBSection;
  5522. begin
  5523.   with FImage do
  5524.     if FDIB.dsbm.bmWidth <> Value then
  5525.     begin
  5526.       HandleNeeded;
  5527.       DIB := FDIB;
  5528.       DIB.dsbm.bmWidth := Value;
  5529.       DIB.dsbmih.biWidth := Value;
  5530.       CopyImage(FHandle, FPalette, DIB);
  5531.       Changed(Self);
  5532.     end;
  5533. end;
  5534.  
  5535. procedure TBitmap.WriteData(Stream: TStream);
  5536. begin
  5537.   WriteStream(Stream, True);
  5538. end;
  5539.  
  5540. procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
  5541. const
  5542.   PalSize: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
  5543. var
  5544.   Size: Integer;
  5545.   HeaderSize: Integer;
  5546.   BMF: TBitmapFileHeader;
  5547.   Save: THandle;
  5548.   BC: TBitmapCoreHeader;
  5549.   ColorCount: Integer;
  5550.   Colors: array [Byte] of TRGBQuad;
  5551. begin
  5552.   DIBNeeded;
  5553.   with FImage do
  5554.   begin
  5555.     Size := 0;
  5556.     if FDIBHandle <> 0 then
  5557.     begin
  5558.       InternalGetDIBSizes(FDIBHandle, HeaderSize, Size, 0);
  5559.       if FOS2Format then
  5560.       begin
  5561.         HeaderSize := sizeof(BC);
  5562.         if FDIB.dsbmih.biBitCount <= 8 then
  5563.           Inc(HeaderSize, sizeof(TRGBTriple) * (1 shl FDIB.dsbmih.biBitCount));
  5564.       end;
  5565.       Inc(Size, HeaderSize + sizeof(BMF));
  5566.     end;
  5567.     if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));
  5568.     if Size <> 0 then
  5569.     begin
  5570.       FillChar(BMF, sizeof(BMF), 0);
  5571.       BMF.bfType := $4D42;
  5572.       BMF.bfSize := Size;
  5573.       BMF.bfOffBits := sizeof(BMF) + HeaderSize;
  5574.  
  5575.       Canvas.RequiredState([csHandleValid]);
  5576.       Save := GDICheck(SelectObject(FCanvas.FHandle, FDIBHandle));
  5577.       ColorCount := GetDIBColorTable(FCanvas.FHandle, 0, 256, Colors);
  5578.       SelectObject(FCanvas.FHandle, Save);
  5579.       if (ColorCount = 0) and (FPalette <> 0) and not FHalftone then
  5580.         ColorCount := PaletteToDIBColorTable(FPalette, Colors);
  5581.  
  5582.       if (FDIB.dsbmih.biBitCount = 16) and
  5583.         ((FDIB.dsbmih.biCompression and BI_BITFIELDS) <> 0) and
  5584.         (FDIB.dsBitFields[0] = 0) then  // fix NT 3.51 driver bug in 5-6-5 mode
  5585.       begin
  5586.         FDIB.dsBitFields[0] := $F800;
  5587.         FDIB.dsBitFields[1] := $07E0;
  5588.         FDIB.dsBitFields[2] := $001F;
  5589.       end;
  5590.  
  5591.       if (ColorCount <> 0) then
  5592.       begin
  5593.         if (FDIB.dsbmih.biClrUsed = 0) or (FDIB.dsbmih.biClrUsed <> ColorCount) then
  5594.           FDIB.dsbmih.biClrUsed := ColorCount;
  5595.         if FOS2Format then RGBQuadToTriple(Colors, ColorCount);
  5596.       end;
  5597.       if FOS2Format then
  5598.       begin
  5599.         with BC, FDIB.dsbmih do
  5600.         begin
  5601.           bcSize := sizeof(BC);
  5602.           bcWidth := biWidth;
  5603.           bcHeight := biHeight;
  5604.           bcPlanes := 1;
  5605.           bcBitCount := biBitCount;
  5606.         end;
  5607.         Stream.WriteBuffer(BMF, sizeof(BMF));
  5608.         Stream.WriteBuffer(BC, sizeof(BC));
  5609.       end
  5610.       else
  5611.       begin
  5612.         Stream.WriteBuffer(BMF, Sizeof(BMF));
  5613.         Stream.WriteBuffer(FDIB.dsbmih, Sizeof(FDIB.dsbmih));
  5614.         if (FDIB.dsbmih.biBitCount > 8) and
  5615.           ((FDIB.dsbmih.biCompression and BI_BITFIELDS) <> 0) then
  5616.           Stream.WriteBuffer(FDIB.dsBitfields, 12);
  5617.       end;
  5618.       Stream.WriteBuffer(Colors, ColorCount * PalSize[FOS2Format]);
  5619.       Stream.WriteBuffer(FDIB.dsbm.bmBits^, FDIB.dsbmih.biSizeImage);
  5620.     end;
  5621.   end;
  5622. end;
  5623.  
  5624.  
  5625. { ReleaseHandle gives up ownership of the bitmap handle the TBitmap contains. }
  5626. function TBitmap.ReleaseHandle: HBITMAP;
  5627. begin
  5628.   HandleNeeded;
  5629.   Changing(Self);
  5630.   with FImage do
  5631.   begin
  5632.     Result := FHandle;
  5633.     if FHandle = FDIBHandle then
  5634.     begin
  5635.       FDIBHandle := 0;
  5636.       FDIB.dsbm.bmBits := nil;
  5637.     end;
  5638.     FHandle := 0;
  5639.   end;
  5640. end;
  5641.  
  5642. function TBitmap.ReleasePalette: HPALETTE;
  5643. begin
  5644.   HandleNeeded;
  5645.   Changing(Self);
  5646.   Result := FImage.FPalette;
  5647.   FImage.FPalette := 0;
  5648. end;
  5649.  
  5650. (*
  5651. function TBitmap.ReplaceColors(const OriginalColors, NewColors: array of TColor): Boolean;
  5652.  
  5653.   function GetShiftCount(I: Integer): Integer;
  5654.   begin
  5655.     Result := 0;
  5656.     while (I and 1) = 0 do
  5657.     begin
  5658.       Inc(Result);
  5659.       I := I shr 1;
  5660.     end;
  5661.   end;
  5662.  
  5663.   function GetBitCount(X: Integer): Integer;
  5664.   var
  5665.     I: Integer;
  5666.   begin
  5667.     Result := 0;
  5668.     for I := 0 to 31 do
  5669.       if (X and (1 shl I)) <> 0 then Inc(Result);
  5670.   end;
  5671.  
  5672. type
  5673.   TDIBMasks = record
  5674.     Mask, Shift, BitCount, RGBMask: Integer;
  5675.   end;
  5676.  
  5677.   procedure Init(var DIBMask: TDIBMasks; RGBShift: Integer);
  5678.   begin
  5679.     with DIBMask do
  5680.     begin
  5681.       Shift := GetShiftCount(Mask);
  5682.       BitCount := GetBitCount(Mask);
  5683.       RGBMask := Mask shr Shift shl (8 + RGBShift - BitCount);
  5684.     end;
  5685.   end;
  5686.  
  5687.   function CvtColorChannel(Clr: Integer; const DIBMask: TDIBMasks; RGBShift: Integer): Integer;
  5688.   begin
  5689.     with DIBMask do
  5690.       Result := (Clr and RGBMask) shr (8 + RGBShift - BitCount) shl Shift;
  5691.   end;
  5692.  
  5693. var
  5694.   I,J,K,ColorCount, LineSize, PixelSize, Tmp: Integer;
  5695.   Red, Green, Blue: TDIBMasks;
  5696.   Colors: array [Byte] of Integer;
  5697.   P: PInteger;
  5698.   RestoreHandleType: TBitmapHandleType;
  5699. begin
  5700.   Result := False;
  5701.   if High(OriginalColors) <> High(NewColors) then InvalidOperation(sColorCountsDiffer);
  5702.   RestoreHandleType := HandleType;
  5703.   HandleType := bmDIB;
  5704.   with FImage, FDIB, FDIB.dsbmih do
  5705.   begin
  5706.     if biBitCount <= 8 then // Replace colors in DIB color table
  5707.     begin
  5708.       ColorCount := GetDIBColorTable(Canvas.Handle, 0, 256, Colors);
  5709.       if ColorCount = 0 then Exit;
  5710.       for I := 0 to ColorCount-1 do
  5711.         for J := 0 to High(OriginalColors) do
  5712.           if (ColorToRGB(OriginalColors[J]) and $FFFFFF) = Colors[I] then
  5713.           begin
  5714.             Colors[I] := ColorToRGB(NewColors[J]);
  5715.             Result := True;
  5716.             Break;
  5717.           end;
  5718.       if Result then
  5719.       begin
  5720.         Changing(Self);
  5721.         SetDIBColorTable(Canvas.Handle, 0, ColorCount, Colors);
  5722.         Tmp := FHandle;
  5723.         FHandle := 0;
  5724.         FDIBHandle := 0;
  5725.         NewImage(Tmp, 0, FDIB, FOS2Format);
  5726.         Changed(Self);
  5727.       end;
  5728.     end
  5729.     else  // Replace colors in DIB pixels directly
  5730.     begin
  5731.       Changing(Self);
  5732.       P := DIBMemory;
  5733.       LineSize := BytesPerScanline(biWidth, biBitCount, 32);
  5734.       PixelSize := biBitCount div 8;
  5735.       if biCompression = BI_BitFields then
  5736.       begin
  5737.         Red.Mask := dsBitFields[0];
  5738.         Green.Mask := dsBitFields[1];
  5739.         Blue.Mask := dsBitFields[2];
  5740.       end
  5741.       else
  5742.       begin
  5743.         Red.Mask := clRed;
  5744.         Green.Mask := clGreen;
  5745.         Blue.Mask := clBlue;
  5746.       end;
  5747.       Init(Red, 0);
  5748.       Init(Green, 8);
  5749.       Init(Blue, 16);
  5750.  
  5751.       for I := 0 to Height-1 do
  5752.       begin
  5753.         for J := 0 to Width-1 do
  5754.         begin
  5755.           for K := 0 to High(OriginalColors) do
  5756.           begin
  5757.             Tmp := ColorToRGB(OriginalColors[K]);
  5758.             if ((P^ and Red.Mask) = (Tmp and Red.RGBMask)) and
  5759.                ((P^ and Green.Mask) = (Tmp and Green.RGBMask)) and
  5760.                ((P^ and Blue.Mask) = (Tmp and Blue.RGBMask)) then
  5761.             begin
  5762.               Result := True;
  5763.               Tmp := ColorToRGB(NewColors[K]);
  5764.               P^ := CvtColorChannel(Tmp, Red, 0) or
  5765.                     CvtColorChannel(Tmp, Green, 8) or
  5766.                     CvtColorChannel(Tmp, Blue, 16);
  5767.               Break;
  5768.             end;
  5769.           end;
  5770.           Inc(Longint(P), PixelSize);
  5771.         end;
  5772.         Inc(Longint(P), LineSize - (biWidth * PixelSize));
  5773.       end;
  5774.       if Result then Changed(Self);
  5775.     end;
  5776.   end;
  5777.   HandleType := RestoreHandleType;
  5778. end;
  5779. *)
  5780.  
  5781. procedure TBitmap.SaveToStream(Stream: TStream);
  5782. begin
  5783.   WriteStream(Stream, False);
  5784. end;
  5785.  
  5786. procedure TBitmap.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  5787.   var APalette: HPALETTE);
  5788. var
  5789.   DIB: TDIBSection;
  5790. begin
  5791.   Format := CF_BITMAP;
  5792.   HandleNeeded;
  5793.   with FImage do
  5794.   begin
  5795.     DIB := FDIB;
  5796.     Data := CopyBitmap(FHandle, FPalette, DIB, FCanvas);
  5797.   end;
  5798.   try
  5799.     APalette := CopyPalette(FImage.FPalette);
  5800.   except
  5801.     DeleteObject(Data);
  5802.     raise;
  5803.   end;
  5804. end;
  5805.  
  5806. { TIconImage }
  5807.  
  5808. destructor TIconImage.Destroy;
  5809. begin
  5810.   FMemoryImage.Free;
  5811.   inherited Destroy;
  5812. end;
  5813.  
  5814. procedure TIconImage.FreeHandle;
  5815. begin
  5816.   if FHandle <> 0 then DestroyIcon(FHandle);
  5817.   FHandle := 0;
  5818. end;
  5819.  
  5820. { TIcon }
  5821.  
  5822. constructor TIcon.Create;
  5823. begin
  5824.   inherited Create;
  5825.   Transparent := True;
  5826.   FImage := TIconImage.Create;
  5827.   FImage.Reference;
  5828. end;
  5829.  
  5830. destructor TIcon.Destroy;
  5831. begin
  5832.   FImage.Release;
  5833.   inherited Destroy;
  5834. end;
  5835.  
  5836. procedure TIcon.Assign(Source: TPersistent);
  5837. begin
  5838.   if (Source = nil) or (Source is TIcon) then
  5839.   begin
  5840.     if Source <> nil then
  5841.     begin
  5842.       TIcon(Source).FImage.Reference;
  5843.       FImage.Release;
  5844.       FImage := TIcon(Source).FImage;
  5845.     end else
  5846.       NewImage(0, nil);
  5847.     Changed(Self);
  5848.     Exit;
  5849.   end;
  5850.   inherited Assign(Source);
  5851. end;
  5852.  
  5853. procedure TIcon.Draw(ACanvas: TCanvas; const Rect: TRect);
  5854. begin
  5855.   with Rect.TopLeft do
  5856.   begin
  5857.     ACanvas.RequiredState([csHandleValid]);
  5858.     DrawIcon(ACanvas.FHandle, X, Y, Handle);
  5859.   end;
  5860. end;
  5861.  
  5862. function TIcon.GetEmpty: Boolean;
  5863. begin
  5864.   with FImage do
  5865.     Result := (FHandle = 0) and (FMemoryImage = nil);
  5866. end;
  5867.  
  5868. function TIcon.GetHandle: HICON;
  5869. begin
  5870.   HandleNeeded;
  5871.   Result := FImage.FHandle;
  5872. end;
  5873.  
  5874. function TIcon.GetHeight: Integer;
  5875. begin
  5876.   Result := GetSystemMetrics(SM_CYICON);
  5877. end;
  5878.  
  5879. function TIcon.GetWidth: Integer;
  5880. begin
  5881.   Result := GetSystemMetrics(SM_CXICON);
  5882. end;
  5883.  
  5884. procedure TIcon.HandleNeeded;
  5885. var
  5886.   CI: TCursorOrIcon;
  5887.   NewHandle: HICON;
  5888. begin
  5889.   with FImage do
  5890.   begin
  5891.     if FHandle <> 0 then Exit;
  5892.     if FMemoryImage = nil then Exit;
  5893.     FMemoryImage.Position := 0;
  5894.     FMemoryImage.ReadBuffer(CI, SizeOf(CI));
  5895.     case CI.wType of
  5896.       RC3_STOCKICON: NewHandle := StockIcon;
  5897.       RC3_ICON: ReadIcon(FMemoryImage, NewHandle, CI.Count, SizeOf(CI));
  5898.     else
  5899.       InvalidIcon;
  5900.     end;
  5901.     FHandle := NewHandle;
  5902.   end;
  5903. end;
  5904.  
  5905. procedure TIcon.ImageNeeded;
  5906. var
  5907.   Image: TMemoryStream;
  5908.   CI: TCursorOrIcon;
  5909. begin
  5910.   with FImage do
  5911.   begin
  5912.     if FMemoryImage <> nil then Exit;
  5913.     if FHandle = 0 then InvalidIcon;
  5914.     Image := TMemoryStream.Create;
  5915.     try
  5916.       if GetHandle = StockIcon then
  5917.       begin
  5918.         FillChar(CI, SizeOf(CI), 0);
  5919.         Image.WriteBuffer(CI, SizeOf(CI));
  5920.       end
  5921.       else
  5922.         WriteIcon(Image, Handle, False);
  5923.     except
  5924.       Image.Free;
  5925.       raise;
  5926.     end;
  5927.     FMemoryImage := Image;
  5928.   end;
  5929. end;
  5930.  
  5931. procedure TIcon.LoadFromStream(Stream: TStream);
  5932. var
  5933.   Image: TMemoryStream;
  5934.   CI: TCursorOrIcon;
  5935. begin
  5936.   Image := TMemoryStream.Create;
  5937.   try
  5938.     Image.SetSize(Stream.Size - Stream.Position);
  5939.     Stream.ReadBuffer(Image.Memory^, Image.Size);
  5940.     Image.ReadBuffer(CI, SizeOf(CI));
  5941.     if not (CI.wType in [RC3_STOCKICON, RC3_ICON]) then InvalidIcon;
  5942.     NewImage(0, Image);
  5943.   except
  5944.     Image.Free;
  5945.     raise;
  5946.   end;
  5947.   Changed(Self);
  5948. end;
  5949.  
  5950. procedure TIcon.NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  5951. var
  5952.   Image: TIconImage;
  5953. begin
  5954.   Image := TIconImage.Create;
  5955.   try
  5956.     Image.FHandle := NewHandle;
  5957.     Image.FMemoryImage := NewImage;
  5958.   except
  5959.     Image.Free;
  5960.     raise;
  5961.   end;
  5962.   Image.Reference;
  5963.   FImage.Release;
  5964.   FImage := Image;
  5965. end;
  5966.  
  5967. function TIcon.ReleaseHandle: HICON;
  5968. begin
  5969.   with FImage do
  5970.   begin
  5971.     if FRefCount > 1 then NewImage(CopyIcon(FHandle), nil);
  5972.     Result := FHandle;
  5973.     FHandle := 0;
  5974.   end;
  5975.   Changed(Self);
  5976. end;
  5977.  
  5978. procedure TIcon.SetHandle(Value: HICON);
  5979. begin
  5980.   NewImage(Value, nil);
  5981.   Changed(Self);
  5982. end;
  5983.  
  5984. procedure TIcon.SetHeight(Value: Integer);
  5985. begin
  5986.   InvalidOperation(SChangeIconSize);
  5987. end;
  5988.  
  5989. procedure TIcon.SetWidth(Value: Integer);
  5990. begin
  5991.   InvalidOperation(SChangeIconSize);
  5992. end;
  5993.  
  5994. procedure TIcon.SaveToStream(Stream: TStream);
  5995. begin
  5996.   ImageNeeded;
  5997.   with FImage.FMemoryImage do Stream.WriteBuffer(Memory^, Size);
  5998. end;
  5999.  
  6000. procedure TIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  6001.   APalette: HPALETTE);
  6002. begin
  6003.   InvalidOperation(SIconToClipboard);
  6004. end;
  6005.  
  6006.  
  6007. procedure TIcon.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  6008.   var APalette: HPALETTE);
  6009. begin
  6010.   InvalidOperation(SIconToClipboard);
  6011. end;
  6012.  
  6013.  
  6014. function GraphicFilter(GraphicClass: TGraphicClass): string;
  6015. var
  6016.   Filters: string;
  6017. begin
  6018.   GetFileFormats.BuildFilterStrings(GraphicClass, Result, Filters);
  6019. end;
  6020.  
  6021. function GraphicExtension(GraphicClass: TGraphicClass): string;
  6022. var
  6023.   I: Integer;
  6024. begin
  6025.   for I := GetFileFormats.Count-1 downto 0 do
  6026.     if PFileFormat(FileFormats[I])^.GraphicClass.InheritsFrom(GraphicClass) then
  6027.     begin
  6028.       Result := PFileFormat(FileFormats[I])^.Extension;
  6029.       Exit;
  6030.     end;
  6031.   Result := '';
  6032. end;
  6033.  
  6034. function GraphicFileMask(GraphicClass: TGraphicClass): string;
  6035. var
  6036.   Descriptions: string;
  6037. begin
  6038.   GetFileFormats.BuildFilterStrings(GraphicClass, Descriptions, Result);
  6039. end;
  6040.  
  6041. procedure InitScreenLogPixels;
  6042. const
  6043.   Pal16: array [0..15] of Integer =
  6044.     (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clDkGray,
  6045.      clLtGray, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
  6046. var
  6047.   DC: HDC;
  6048. begin
  6049.   DC := GetDC(0);
  6050.   ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  6051.   ReleaseDC(0,DC);
  6052.   SystemPalette16 := PaletteFromDIBColorTable(0, @Pal16, 16);
  6053. end;
  6054.  
  6055. function GetDefFontCharSet: TFontCharSet;
  6056. var
  6057.   DisplayDC: HDC;
  6058.   TxtMetric: TTEXTMETRIC;
  6059. begin
  6060.   Result := DEFAULT_CHARSET;
  6061.   DisplayDC := GetDC(0);
  6062.   if (DisplayDC <> 0) then
  6063.   begin
  6064.     if (SelectObject(DisplayDC, StockFont) <> 0) then
  6065.       if (GetTextMetrics(DisplayDC, TxtMetric)) then
  6066.         Result := TxtMetric.tmCharSet;
  6067.     ReleaseDC(0, DisplayDC);
  6068.   end;
  6069. end;
  6070.  
  6071. procedure InitDefFontData;
  6072. var
  6073.   Charset: TFontCharset;
  6074. begin
  6075.   DefFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
  6076.   if not SysLocale.FarEast then Exit;
  6077.   Charset := GetDefFontCharset;
  6078.   case Charset of
  6079.     SHIFTJIS_CHARSET:
  6080.       begin
  6081.         DefFontData.Name := 'élér éoâSâVâbâN';
  6082.         DefFontData.Height := -MulDiv(9, ScreenLogPixels, 72);
  6083.         DefFontData.CharSet := CharSet;
  6084.       end;
  6085.   end;
  6086. end;
  6087.  
  6088. initialization
  6089.   InitScreenLogPixels;
  6090.   InitializeCriticalSection(BitmapImageLock);
  6091.   StockPen := GetStockObject(BLACK_PEN);
  6092.   StockBrush := GetStockObject(HOLLOW_BRUSH);
  6093.   StockFont := GetStockObject(SYSTEM_FONT);
  6094.   StockIcon := LoadIcon(0, IDI_APPLICATION);
  6095.   InitDefFontData;
  6096.   FontManager := TResourceManager.Create(SizeOf(TFontData));
  6097.   PenManager := TResourceManager.Create(SizeOf(TPenData));
  6098.   BrushManager := TResourceManager.Create(SizeOf(TBrushData));
  6099.   BitmapCanvasList := TThreadList.Create;
  6100.   CanvasList := TThreadList.Create;
  6101.   RegisterIntegerConsts(TypeInfo(TColor), IdentToColor, ColorToIdent);
  6102.   RegisterIntegerConsts(TypeInfo(TFontCharset), IdentToCharset, CharsetToIdent);
  6103. finalization
  6104.   FileFormats.Free;
  6105.   ClipboardFormats.Free;
  6106.   MonoBmp.Free;
  6107.   DevBmp.Free;
  6108.   FreeMemoryContexts;
  6109.   BitmapCanvasList.Free;
  6110.   CanvasList.Free;
  6111.   FontManager.Free;
  6112.   PenManager.Free;
  6113.   BrushManager.Free;
  6114.   DeleteObject(SystemPalette16);
  6115.   DeleteCriticalSection(BitmapImageLock);
  6116. end.
  6117.